diff options
Diffstat (limited to 'plugins')
78 files changed, 4927 insertions, 2266 deletions
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 50fc2448fc..0e3b9fc2b6 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -67,7 +67,7 @@ let rec decompose_term env sigma t= let canon_mind = MutInd.make1 (MutInd.canonical mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in - let nargs=constructor_nallargs_env env (canon_ind,i_con) in + let nargs=constructor_nallargs env (canon_ind,i_con) in Constructor {ci_constr= ((canon_ind,i_con),u); ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 4425e41652..4769c2dc53 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -102,6 +102,7 @@ let start_deriving f suchthat lemma = let terminator = Proof_global.make_terminator terminator in let pstate = Proof_global.start_dependent_proof ~ontop:None lemma kind goals terminator in - fst @@ Proof_global.with_current_proof begin fun _ p -> - Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p + Proof_global.simple_with_current_proof begin fun _ p -> + let p,_,() = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p in + p end pstate diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index c9cfd74362..9db7c8d8d3 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -854,7 +854,7 @@ and extract_cons_app env sg mle mlt (((kn,i) as ip,j) as cp) args = and extract_case env sg mle ((kn,i) as ip,c,br) mlt = (* [br]: bodies of each branch (in functional form) *) (* [ni]: number of arguments without parameters in each branch *) - let ni = constructors_nrealargs_env env ip in + let ni = constructors_nrealargs env ip in let br_size = Array.length br in assert (Int.equal (Array.length ni) br_size); if Int.equal br_size 0 then begin diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 56b3dc97cf..4b7bc707d6 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -82,13 +82,13 @@ let pop t = Vars.lift (-1) t let kind_of_formula env sigma term = let normalize = special_nf env sigma in let cciterm = special_whd env sigma term in - match match_with_imp_term sigma cciterm with + match match_with_imp_term env sigma cciterm with Some (a,b)-> Arrow (a, pop b) |_-> - match match_with_forall_term sigma cciterm with + match match_with_forall_term env sigma cciterm with Some (_,a,b)-> Forall (a, b) |_-> - match match_with_nodep_ind sigma cciterm with + match match_with_nodep_ind env sigma cciterm with Some (i,l,n)-> let ind,u=EConstr.destInd sigma i in let u = EConstr.EInstance.kind sigma u in @@ -111,7 +111,7 @@ let kind_of_formula env sigma term = else Or((ind,u),l,is_trivial) | _ -> - match match_with_sigma_type sigma cciterm with + match match_with_sigma_type env sigma cciterm with Some (i,l)-> let (ind, u) = EConstr.destInd sigma i in let u = EConstr.EInstance.kind sigma u in diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 01b18e2f30..9f2ceb2c28 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -188,7 +188,7 @@ let empty_seq depth= let expand_constructor_hints = List.map_append (function | GlobRef.IndRef ind -> - List.init (Inductiveops.nconstructors ind) + List.init (Inductiveops.nconstructors (Global.env()) ind) (fun i -> GlobRef.ConstructRef (ind,i+1)) | gr -> [gr]) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 4e8cf80ed2..dbfc0fc91d 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -179,11 +179,13 @@ let () = VERNAC COMMAND EXTEND Function | ![ proof ] ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] => { let hard = List.exists (function - | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true - | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in + | _,((_,(Some { CAst.v = CMeasureRec _ } + | Some { CAst.v = CWfRec _}),_,_,_),_) -> true + | _,((_,Some { CAst.v = CStructRec _ },_,_,_),_) + | _,((_,None,_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) + (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacextend.VtSideff ids, _ when hard -> Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 275b58f0aa..e15e167ff3 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -317,7 +317,7 @@ let build_constructors_of_type ind' argl = Impargs.implicits_of_global constructref in let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) construct in @@ -330,7 +330,7 @@ let build_constructors_of_type ind' argl = let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) in - cases_pattern_of_glob_constr Anonymous pat_as_term + cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term ) ind.Declarations.mind_consnames @@ -415,7 +415,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) constr in @@ -1518,7 +1518,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1533,7 +1533,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 13ff19a46b..7b758da8e8 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -361,7 +361,7 @@ let rec pattern_to_term pt = DAst.with_val (function mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = - Inductiveops.constructor_nallargs_env + Inductiveops.constructor_nallargs (Global.env ()) constr in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a5c19f3217..6494e90a03 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -382,8 +382,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let _ = List.map_i (fun i x -> - let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in - let env = Global.env () in + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn,i) (InProp) in let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in @@ -469,11 +469,6 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas CAst.(with_val (fun x -> x)) (Constrexpr_ops.names_of_local_assums args) in - match wf_arg with - | None -> - if Int.equal (List.length names) 1 then 1 - else error "Recursive argument must be specified" - | Some wf_arg -> List.index Name.equal (Name wf_arg) names in let unbounded_eq = @@ -575,7 +570,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas in wf_rel_with_mes,false in - register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg) + register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body let map_option f = function @@ -623,15 +618,15 @@ and rebuild_nal aux bk bl' nal typ = let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = - let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in + let fixl,ntns = ComFixpoint.extract_fixpoint_components ~structonly:false fixpoint_exprl in let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = - List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> + List.map2 (fun ((lna,rec_order_opt,bl,ret_typ,opt_body),notation_list) fix_typ -> let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in - (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + (((lna,rec_order_opt,new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixpoint_exprl constr_expr_typel in @@ -643,7 +638,7 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let pstate, _is_struct = match fixpoint_exprl with - | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> + | [((_,Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -665,9 +660,9 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive true in if register_built - then register_wf name rec_impls wf_rel (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, false + then register_wf name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false else pstate, false - |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> + |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e @@ -692,9 +687,9 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive then register_mes name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true else pstate, true | _ -> - List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> + List.iter (function ((_na,ord,_args,_body,_type),_not) -> match ord with - | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ -> + | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> error ("Cannot use mutual definition with well-founded recursion or measure") | _ -> () @@ -869,38 +864,42 @@ let make_graph ~pstate (f_ref : GlobRef.t) = ) () in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,(n,recexp),bl,t,b) -> - let { CAst.loc; v=rec_id } = Option.get n in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - ((((id,None), ( Some CAst.(make rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) - ) - fixexprl - in - l + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> + let l = + List.map + (fun (id,recexp,bl,t,b) -> + let { CAst.loc; v=rec_id } = match Option.get recexp with + | { CAst.v = CStructRec id } -> id + | { CAst.v = CWfRec (id,_) } -> id + | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> + List.map + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) + nal + | Constrexpr.CLocalPattern _ -> assert false + ) + nal_tas + ) + in + let b' = add_args id.CAst.v new_args b in + ((((id,None), ( Some (CAst.make (CStructRec (CAst.make rec_id)))),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ) + fixexprl + in + l | _ -> let id = Label.to_id (Constant.label c) in - [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + [((CAst.make id,None),None,nal_tas,t,Some b),[]] in let mp = Constant.modpath c in let pstate = do_generate_principle ~pstate [c,Univ.Instance.empty] error_error false false expr_list in diff --git a/plugins/funind/plugin_base.dune b/plugins/funind/plugin_base.dune index 002eb28eea..6ccf15df29 100644 --- a/plugins/funind/plugin_base.dune +++ b/plugins/funind/plugin_base.dune @@ -1,5 +1,5 @@ (library (name recdef_plugin) - (public_name coq.plugins.recdef) + (public_name coq.plugins.funind) (synopsis "Coq's functional induction plugin") (libraries coq.plugins.extraction)) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 3c2b03dfe0..1fca132655 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -132,7 +132,7 @@ let nat = function () -> (coq_init_constant "nat") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") -let iter_rd = function () -> (constr_of_global (delayed_force iter_ref)) +let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) let eq = function () -> (coq_init_constant "eq") let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm") @@ -145,7 +145,7 @@ let coq_O = function () -> (coq_init_constant "O") 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 max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -701,7 +701,7 @@ let mkDestructEq : let changefun patvars env sigma = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in - Proofview.V82.of_tactic (change_in_concl None changefun) g2); + Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert @@ -1041,13 +1041,13 @@ let compute_terminate_type nb_args func = let open Term in let open Constr in let open CVars in - let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in + let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_monomorphic_global func)) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = mkApp(delayed_force iter_rd, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: - constr_of_global func::mkRel 1:: + constr_of_monomorphic_global func::mkRel 1:: List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) @@ -1065,7 +1065,7 @@ let compute_terminate_type nb_args func = delayed_force nat, (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, mkArrow cond Sorts.Relevant result))))|])in - let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), + let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), [|b; (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in compose_prod rev_args value @@ -1161,7 +1161,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a fun g -> let sigma = project g in let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_global func)) in + let func_body = (def_of_const (constr_of_monomorphic_global func)) in let func_body = EConstr.of_constr func_body in let (f_name, _, body1) = destLambda sigma func_body in let f_id = @@ -1222,7 +1222,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types pstate = let p = Proof_global.give_me_the_proof pstate in - let sgs,_,_,_,sigma = Proof.proof p in + let Proof.{ goals=sgs; sigma; _ } = Proof.data p in sigma, List.map (Goal.V82.abstract_type sigma) sgs exception EmptySubgoals @@ -1253,7 +1253,7 @@ let build_and_l sigma l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_global conj_constr)))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) [tclIDTAC; tac ],nb+1 @@ -1437,7 +1437,7 @@ let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_global term_f in + let terminate_constr = constr_of_monomorphic_global term_f in let terminate_constr = EConstr.of_constr terminate_constr in let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in @@ -1457,7 +1457,7 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in let evd = Evd.from_ctx uctx in - let f_constr = constr_of_global f_ref in + let f_constr = constr_of_monomorphic_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in let pstate = Lemmas.start_proof ~ontop:None eq_name (Global, false, Proof Lemma) ~sign evd (EConstr.of_constr equation_lemma_type) in @@ -1466,12 +1466,12 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation (fun x -> prove_eq (fun _ -> tclIDTAC) {nb_arg=nb_arg; - f_terminate = EConstr.of_constr (constr_of_global terminate_ref); + f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); f_constr = EConstr.of_constr f_constr; concl_tac = tclIDTAC; func=functional_ref; info=(instantiate_lambda Evd.empty - (EConstr.of_constr (def_of_const (constr_of_global functional_ref))) + (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) (EConstr.of_constr f_constr::List.map mkVar x) ); is_main_branch = true; @@ -1570,9 +1570,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num if not stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in - let f_ref = destConst (constr_of_global f_ref) - and functional_ref = destConst (constr_of_global functional_ref) - and eq_ref = destConst (constr_of_global eq_ref) in + let f_ref = destConst (constr_of_monomorphic_global f_ref) + and functional_ref = destConst (constr_of_monomorphic_global functional_ref) + and eq_ref = destConst (constr_of_monomorphic_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 523c7c8305..e59076bd63 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -182,9 +182,18 @@ TACTIC EXTEND unify } END +{ +let deprecated_convert_concl_no_check = + CWarnings.create + ~name:"convert_concl_no_check" ~category:"deprecated" + (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") +} TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl_no_check x DEFAULTcast } +| ["convert_concl_no_check" constr(x) ] -> { + deprecated_convert_concl_no_check (); + Tactics.convert_concl ~check:false x DEFAULTcast + } END { diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 3f2fabeeee..049a699cbd 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -84,7 +84,7 @@ TACTIC EXTEND typeclasses_eauto | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d l } | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { - typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] } + typeclasses_eauto ~only_classes:true ~depth:d [Class_tactics.typeclasses_db] } END TACTIC EXTEND head_of_constr diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 7bf705ffeb..c23240b782 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -72,7 +72,7 @@ let test_lpar_idnum_coloneq = match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with - | IDENT _ | INT _ -> + | IDENT _ | NUMERAL _ -> (match stream_nth 2 strm with | KEYWORD ":=" -> () | _ -> err ()) @@ -147,7 +147,8 @@ let destruction_arg_of_constr (c,lbind as clbind) = match lbind with end | _ -> ElimOnConstr clbind -let mkNumeral n = Numeral (string_of_int (abs n), 0<=n) +let mkNumeral n = + Numeral ((if 0<=n then SPlus else SMinus),NumTok.int (string_of_int (abs n))) let mkTacCase with_evar = function | [(clear,ElimOnConstr cl),(None,None),None],None -> @@ -702,7 +703,11 @@ GRAMMAR EXTEND Gram | IDENT "change"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in let p,cl = merge_occurrences loc cl oc in - TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } + TacAtom (CAst.make ~loc @@ TacChange (true,p,c,cl)) } + | IDENT "change_no_check"; c = conversion; cl = clause_dft_concl -> + { let (oc, c) = c in + let p,cl = merge_occurrences loc cl oc in + TacAtom (CAst.make ~loc @@ TacChange (false,p,c,cl)) } ] ] ; END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 80070a7493..79f0f521cc 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -833,9 +833,10 @@ let pr_goal_selector ~toplevel s = pr_red_expr r ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) - | TacChange (op,c,h) -> + | TacChange (check,op,c,h) -> + let name = if check then "change_no_check" else "change" in hov 1 ( - primitive "change" ++ brk (1,1) + primitive name ++ brk (1,1) ++ ( match op with None -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 75565c1a34..a68efa4713 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -119,7 +119,7 @@ let app_poly_check env evars f args = (evars, cstrs), t let app_poly_nocheck env evars f args = - let evars, fc = f evars in + let evars, fc = f evars in evars, mkApp (fc, args) let app_poly_sort b = @@ -175,25 +175,29 @@ end) = struct let rewrite_relation_class = find_global relation_classes "RewriteRelation" - let proper_class = lazy (class_info (find_reference morphisms "Proper")) - let proper_proxy_class = lazy (class_info (find_reference morphisms "ProperProxy")) - - let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - - let proper_type = - let l = lazy (Lazy.force proper_class).cl_impl in - fun (evd,cstrs) -> - let (evd, c) = Evarutil.new_global evd (Lazy.force l) in - (evd, cstrs), c - - let proper_proxy_type = - let l = lazy (Lazy.force proper_proxy_class).cl_impl in - fun (evd,cstrs) -> - let (evd, c) = Evarutil.new_global evd (Lazy.force l) in - (evd, cstrs), c + let proper_class = + let r = lazy (find_reference morphisms "Proper") in + fun env sigma -> class_info env sigma (Lazy.force r) + + let proper_proxy_class = + let r = lazy (find_reference morphisms "ProperProxy") in + fun env sigma -> class_info env sigma (Lazy.force r) + + let proper_proj env sigma = + mkConst (Option.get (pi3 (List.hd (proper_class env sigma).cl_projs))) + + let proper_type env (sigma,cstrs) = + let l = (proper_class env sigma).cl_impl in + let (sigma, c) = Evarutil.new_global sigma l in + (sigma, cstrs), c + + let proper_proxy_type env (sigma,cstrs) = + let l = (proper_proxy_class env sigma).cl_impl in + let (sigma, c) = Evarutil.new_global sigma l in + (sigma, cstrs), c let proper_proof env evars carrier relation x = - let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in + let evars, goal = app_poly env evars (proper_proxy_type env) [| carrier ; relation; x |] in new_cstr_evar evars env goal let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env @@ -800,7 +804,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in - let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type env else TypeGlobal.proper_type env) cl_args in let env' = let dosub, appsub = @@ -1310,8 +1314,8 @@ module Strategies = in let evars, proof = let proxy = - if prop then PropGlobal.proper_proxy_type - else TypeGlobal.proper_proxy_type + if prop then PropGlobal.proper_proxy_type env + else TypeGlobal.proper_proxy_type env in let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in new_cstr_evar evars env mty @@ -1570,8 +1574,8 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in (* For compatibility *) - let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in - let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in + let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in + let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") @@ -1592,7 +1596,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> + convert_hyp ~check:false ~reorder:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> @@ -1606,7 +1610,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = end | None, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_concl_no_check newt DEFAULTcast + convert_concl ~check:false newt DEFAULTcast in Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in @@ -1854,12 +1858,12 @@ let declare_relation ~pstate atts ?(binders=[]) a aeq n refl symm trans = let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) -let proper_projection sigma r ty = +let proper_projection env sigma r ty = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in let ctx, inst = decompose_prod_assum sigma ty in let mor, args = destApp sigma inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force PropGlobal.proper_proj, + let app = mkApp (PropGlobal.proper_proj env sigma, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx @@ -1869,7 +1873,7 @@ let declare_projection n instance_id r = let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in - let term = proper_projection sigma c ty in + let term = proper_projection env sigma c ty in let sigma, typ = Typing.type_of env sigma term in let ctx, typ = decompose_prod_assum sigma typ in let typ = @@ -1924,7 +1928,7 @@ let build_morphism_signature env sigma m = rel) cstrs in - let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in + let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in let evd = solve_constraints env !evd in let evd = Evd.minimize_universes evd in let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in @@ -1938,9 +1942,9 @@ let default_morphism sign m = let evars, _, sign, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in - let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in + let evars, morph = app_poly_check env evars (PropGlobal.proper_type env) [| t; sign; m |] in let evars, mor = resolve_one_typeclass env (goalevars evars) morph in - mor, proper_projection sigma mor morph + mor, proper_projection env sigma mor morph let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> @@ -1984,8 +1988,8 @@ let add_morphism_infer ~pstate atts m n : Proof_global.t option = (None,(instance,uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); + add_instance (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst); pstate else @@ -1995,8 +1999,8 @@ let add_morphism_infer ~pstate atts m n : Proof_global.t option = let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook _ _ _ = function | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + add_instance (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index b770b97384..814be64f81 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -48,7 +48,7 @@ let atactic n = else Aentryl (Pltac.tactic_expr, string_of_int n) type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Extend.symbol -> entry_name (** Quite ad-hoc *) let get_tacentry n m = diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 30e316b36d..0eb7726a18 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -125,7 +126,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 8b6b14322b..fd303f5d94 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -124,7 +125,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 543d4de0fe..c1f7fab123 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -551,7 +551,7 @@ let rec intern_atomic lf ist x = | TacReduce (r,cl) -> dump_glob_red_expr r; TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -560,17 +560,17 @@ let rec intern_atomic lf ist x = | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in - TacChange (None, + TacChange (check,None, (if is_onhyps && is_onconcl then intern_type ist c else intern_constr ist c), clause_app (intern_hyp_location ist) cl) - | TacChange (Some p,c,cl) -> + | TacChange (check,Some p,c,cl) -> let { ltacvars } = ist in let metas,pat = intern_typed_pattern ist ~as_type:false ~ltacvars p in let fold accu x = Id.Set.add x accu in let ltacvars = List.fold_left fold ltacvars metas in let ist' = { ist with ltacvars } in - TacChange (Some pat,intern_constr ist' c, + TacChange (check,Some pat,intern_constr ist' c, clause_app (intern_hyp_location ist) cl) (* Equality and inversion *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 4398fb14ab..800be2565d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1770,7 +1770,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) end - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> @@ -1792,10 +1792,10 @@ and interp_atomic ist tac : unit Proofview.tactic = then interp_type ist env sigma c else interp_constr ist env sigma c in - Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) + Tactics.change ~check None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end end - | TacChange (Some op,c,cl) -> + | TacChange (check,Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> @@ -1815,7 +1815,7 @@ and interp_atomic ist tac : unit Proofview.tactic = with e when to_catch e (* Hack *) -> user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") in - Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) + Tactics.change ~check (Some op) c_interp (interp_clause ist env sigma cl) end end diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index caaa547a07..a3eeca2267 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -30,7 +30,7 @@ let subst_quantified_hypothesis _ x = x let subst_declared_or_quantified_hypothesis _ x = x let subst_glob_constr_and_expr subst (c, e) = - (Detyping.subst_glob_constr subst c, e) + (Detyping.subst_glob_constr (Global.env()) subst c, e) let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) @@ -99,7 +99,9 @@ let subst_evaluable subst = let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) let subst_glob_constr_or_pattern subst (bvars,c,p) = - (bvars,subst_glob_constr subst c,subst_pattern subst p) + let env = Global.env () in + let sigma = Evd.from_env env in + (bvars,subst_glob_constr subst c,subst_pattern env sigma subst p) let subst_redexp subst = Redops.map_red_expr_gen @@ -156,8 +158,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) - | TacChange (op,c,cl) -> - TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + | TacChange (check,op,c,cl) -> + TacChange (check,Option.map (subst_glob_constr_or_pattern subst) op, subst_glob_constr subst c, cl) (* Equality and inversion *) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 4c65445b89..d1951cc18d 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -98,16 +98,18 @@ let split = Tactics.split_with_bindings false [Tactypes.NoBindings] (** Test *) let is_empty _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> - if is_empty_type sigma (assoc_var "X1" ist) then idtac else fail + if is_empty_type genv sigma (assoc_var "X1" ist) then idtac else fail (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) let is_unit_or_eq _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test sigma (assoc_var "X1" ist) then idtac else fail + if test genv sigma (assoc_var "X1" ist) then idtac else fail let bugged_is_binary sigma t = isApp sigma t && @@ -121,23 +123,25 @@ let bugged_is_binary sigma t = (** Dealing with conjunction *) let is_conj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let ind = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma ind) && - is_conjunction sigma + is_conjunction genv sigma ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode ind then idtac else fail let flatten_contravariant_conj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in - match match_with_conjunction sigma + match match_with_conjunction genv sigma ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with @@ -151,23 +155,25 @@ let flatten_contravariant_conj _ ist = (** Dealing with disjunction *) let is_disj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let t = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma t) && - is_disjunction sigma + is_disjunction genv sigma ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode t then idtac else fail let flatten_contravariant_disj _ ist = + Proofview.tclENV >>= fun genv -> Proofview.tclEVARMAP >>= fun sigma -> let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in - match match_with_disjunction sigma + match match_with_disjunction genv sigma ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with diff --git a/plugins/micromega/DeclConstant.v b/plugins/micromega/DeclConstant.v new file mode 100644 index 0000000000..47fcac6481 --- /dev/null +++ b/plugins/micromega/DeclConstant.v @@ -0,0 +1,68 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2019 *) +(* *) +(************************************************************************) + +(** Declaring 'allowed' terms using type classes. + + Motivation: reification needs to know which terms are allowed. + For 'lia', the constant are only the integers built from Z0, Zpos, Zneg, xH, xO, xI. + However, if the term is ground it may be convertible to an integer. + Thus we could allow i.e. sqrt z for some integer z. + + Proposal: for each type, the user declares using type-classes the set of allowed ground terms. + *) + +Require Import List. + +(** Declarative definition of constants. + These are ground terms (without variables) of interest. + e.g. nat is built from O and S + NB: this does not need to be restricted to constructors. + *) + +(** Ground terms (see [GT] below) are built inductively from declared constants. *) + +Class DeclaredConstant {T : Type} (F : T). + +Class GT {T : Type} (F : T). + +Instance GT_O {T : Type} (F : T) {DC : DeclaredConstant F} : GT F. +Defined. + +Instance GT_APP1 {T1 T2 : Type} (F : T1 -> T2) (A : T1) : + DeclaredConstant F -> + GT A -> GT (F A). +Defined. + +Instance GT_APP2 {T1 T2 T3: Type} (F : T1 -> T2 -> T3) + {A1 : T1} {A2 : T2} {DC:DeclaredConstant F} : + GT A1 -> GT A2 -> GT (F A1 A2). +Defined. + +Require Import ZArith. + +Instance DO : DeclaredConstant O := {}. +Instance DS : DeclaredConstant S := {}. +Instance DxH: DeclaredConstant xH := {}. +Instance DxI: DeclaredConstant xI := {}. +Instance DxO: DeclaredConstant xO := {}. +Instance DZO: DeclaredConstant Z0 := {}. +Instance DZpos: DeclaredConstant Zpos := {}. +Instance DZneg: DeclaredConstant Zneg := {}. +Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. + +Require Import QArith. + +Instance DQ : DeclaredConstant Qmake := {}. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index eb84b1203d..36ed0210e3 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -594,7 +594,7 @@ Qed. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. - apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). @@ -1085,7 +1085,7 @@ Section POWER. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - simpl. rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index dd6319d5c4..1582ec554e 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -18,6 +18,7 @@ Require Import ZMicromega. Require Import ZArith. Require Import RingMicromega. Require Import VarMap. +Require Import DeclConstant. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". @@ -25,18 +26,22 @@ Declare ML Module "micromega_plugin". Ltac preprocess := zify ; unfold Z.succ in * ; unfold Z.pred in *. -Ltac zchange := +Ltac zchange checker := intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit). + change (@Tauto.eval_bf _ (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (checker __ff __wit). -Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. +Ltac zchecker_no_abstract checker := + zchange checker ; vm_compute ; reflexivity. -Ltac zchecker_abstract := abstract (zchange ; vm_cast_no_check (eq_refl true)). +Ltac zchecker_abstract checker := + abstract (zchange checker ; vm_cast_no_check (eq_refl true)). -Ltac zchecker := zchecker_no_abstract. +Ltac zchecker := zchecker_no_abstract ZTautoChecker_sound. -Ltac lia := preprocess; xlia zchecker. +Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound. + +Ltac lia := preprocess; xlia zchecker_ext. Ltac nia := preprocess; xnlia zchecker. diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v index caaec541eb..f3cd24be8a 100644 --- a/plugins/micromega/Lqa.v +++ b/plugins/micromega/Lqa.v @@ -18,12 +18,13 @@ Require Import QMicromega. Require Import QArith. Require Import RingMicromega. Require Import VarMap. +Require Import DeclConstant. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac rchange := intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + change (Tauto.eval_bf (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit). Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v index 4ff483fbab..72e29319ff 100644 --- a/plugins/micromega/Lra.v +++ b/plugins/micromega/Lra.v @@ -24,7 +24,7 @@ Declare ML Module "micromega_plugin". Ltac rchange := intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + change (Tauto.eval_bf (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit). Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 5f01f981ef..6112eda200 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -54,8 +54,10 @@ 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 "micromega.ml" -(*Recursive Extraction*) List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add + Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ + 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: *) diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index 62505453f9..e0e2232be5 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -87,40 +87,40 @@ Notation "x < y" := (rlt x y). Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. -exact sor.(SORle_wd). +exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. -exact sor.(SORlt_wd). +exact (SORlt_wd sor). Qed. -Add Ring SOR : sor.(SORrt). +Add Ring SOR : (SORrt sor). Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. intros x1 x2 H1 y1 y2 H2. -rewrite (sor.(SORrt).(Rsub_def) x1 y1). -rewrite (sor.(SORrt).(Rsub_def) x2 y2). +rewrite ((Rsub_def (SORrt sor)) x1 y1). +rewrite ((Rsub_def (SORrt sor)) x2 y2). rewrite H1; now rewrite H2. Qed. @@ -180,22 +180,22 @@ Qed. (* Relations *) Theorem Rle_refl : forall n : R, n <= n. -Proof sor.(SORle_refl). +Proof (SORle_refl sor). Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. -Proof sor.(SORle_antisymm). +Proof (SORle_antisymm sor). Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. -Proof sor.(SORle_trans). +Proof (SORle_trans sor). Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. -Proof sor.(SORlt_trichotomy). +Proof (SORlt_trichotomy sor). Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. -Proof sor.(SORlt_le_neq). +Proof (SORlt_le_neq sor). Theorem Rneq_0_1 : 0 ~= 1. -Proof sor.(SORneq_0_1). +Proof (SORneq_0_1 sor). Theorem Req_em : forall n m : R, n == m \/ n ~= m. Proof. @@ -274,8 +274,8 @@ Qed. Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. Proof. intros n m p; split. -apply sor.(SORplus_le_mono_l). -intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. +apply (SORplus_le_mono_l sor). +intro H. apply ((SORplus_le_mono_l sor) (p + n) (p + m) (- p)) in H. setoid_replace (- p + (p + n)) with n in H by ring. setoid_replace (- p + (p + m)) with m in H by ring. assumption. Qed. @@ -375,7 +375,7 @@ Qed. (* Times and order *) Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. -Proof sor.(SORtimes_pos_pos). +Proof (SORtimes_pos_pos sor). Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. Proof. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 2880a05d8d..0d593a321c 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -173,6 +173,7 @@ Qed. Require Import Coq.micromega.Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. + Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. @@ -182,30 +183,36 @@ 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 cnfQ (Annot TX AF: Type) (f: TFormula (Formula Q) Annot TX AF) := + rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) + @tauto_checker (Formula Q) (NFormula Q) unit qunsat qdeduce - Qnormalise - Qnegate QWitness QWeakChecker f w. + (Qnormalise unit) + (Qnegate unit) QWitness (fun cl => QWeakChecker (List.map fst cl)) f w. -Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. +Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_bf (Qeval_formula env) f. Proof. intros f w. unfold QTautoChecker. - apply (tauto_checker_sound Qeval_formula Qeval_nformula). - apply Qeval_nformula_dec. - intros until env. - unfold eval_nformula. unfold RingMicromega.eval_nformula. - destruct t. - apply (check_inconsistent_sound Qsor QSORaddon) ; auto. - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon). - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon). - intros t w0. - apply QWeakChecker_sound. + apply tauto_checker_sound with (eval:= Qeval_formula) (eval':= Qeval_nformula). + - apply Qeval_nformula_dec. + - intros until env. + unfold eval_nformula. unfold RingMicromega.eval_nformula. + destruct t. + apply (check_inconsistent_sound Qsor QSORaddon) ; auto. + - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). + - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_normalise_correct Qsor QSORaddon);eauto. + - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_negate_correct Qsor QSORaddon);eauto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := Qeval_nformula env). + eapply QWeakChecker_sound; eauto. + tauto. Qed. (* Local Variables: *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index c2b40c730f..7704e42d40 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -17,10 +17,11 @@ Require Import OrderedRing. Require Import RingMicromega. Require Import Refl. -Require Import Raxioms RIneq Rpow_def DiscrR. +Require Import Raxioms Rfunctions RIneq Rpow_def DiscrR. Require Import QArith. Require Import Qfield. Require Import Qreals. +Require Import DeclConstant. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -57,8 +58,6 @@ Proof. now apply Rmult_lt_0_compat. Qed. -Notation IQR := Q2R (only parsing). - Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. @@ -66,13 +65,13 @@ Proof. apply Rmult_1_r. Qed. -Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. +Lemma Qeq_true : forall x y, Qeq_bool x y = true -> Q2R x = Q2R y. Proof. intros. now apply Qeq_eqR, Qeq_bool_eq. Qed. -Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. +Lemma Qeq_false : forall x y, Qeq_bool x y = false -> Q2R x <> Q2R y. Proof. intros. apply Qeq_bool_neq in H. @@ -80,24 +79,24 @@ Proof. now apply eqR_Qeq. Qed. -Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. +Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> Q2R x <= Q2R y. Proof. intros. now apply Qle_Rle, Qle_bool_imp_le. Qed. -Lemma IQR_0 : IQR 0 = 0. +Lemma Q2R_0 : Q2R 0 = 0. Proof. apply Rmult_0_l. Qed. -Lemma IQR_1 : IQR 1 = 1. +Lemma Q2R_1 : Q2R 1 = 1. Proof. compute. apply Rinv_1. Qed. -Lemma IQR_inv_ext : forall x, - IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). +Lemma Q2R_inv_ext : forall x, + Q2R (/ x) = (if Qeq_bool x 0 then 0 else / Q2R x). Proof. intros. case_eq (Qeq_bool x 0). @@ -120,12 +119,12 @@ Lemma QSORaddon : R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) Qeq_bool Qle_bool - IQR nat to_nat pow. + Q2R nat to_nat pow. Proof. constructor. constructor ; intros ; try reflexivity. - apply IQR_0. - apply IQR_1. + apply Q2R_0. + apply Q2R_1. apply Q2R_plus. apply Q2R_minus. apply Q2R_mult. @@ -136,20 +135,27 @@ Proof. apply Qle_true. Qed. +(* Syntactic ring coefficients. *) -(* Syntactic ring coefficients. - For computing, we use Q. *) Inductive Rcst := -| C0 -| C1 -| CQ (r : Q) -| CZ (r : Z) -| CPlus (r1 r2 : Rcst) -| CMinus (r1 r2 : Rcst) -| CMult (r1 r2 : Rcst) -| CInv (r : Rcst) -| COpp (r : Rcst). - + | C0 + | C1 + | CQ (r : Q) + | CZ (r : Z) + | CPlus (r1 r2 : Rcst) + | CMinus (r1 r2 : Rcst) + | CMult (r1 r2 : Rcst) + | CPow (r1 : Rcst) (z:Z+nat) + | CInv (r : Rcst) + | COpp (r : Rcst). + + + +Definition z_of_exp (z : Z + nat) := + match z with + | inl z => z + | inr n => Z.of_nat n + end. Fixpoint Q_of_Rcst (r : Rcst) : Q := match r with @@ -160,42 +166,198 @@ Fixpoint Q_of_Rcst (r : Rcst) : Q := | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) - | CInv r => Qinv (Q_of_Rcst r) + | CPow r1 z => Qpower (Q_of_Rcst r1) (z_of_exp z) + | CInv r => Qinv (Q_of_Rcst r) | COpp r => Qopp (Q_of_Rcst r) end. +Definition is_neg (z: Z+nat) := + match z with + | inl (Zneg _) => true + | _ => false + end. + +Lemma is_neg_true : forall z, is_neg z = true -> (z_of_exp z < 0)%Z. +Proof. + destruct z ; simpl ; try congruence. + destruct z ; try congruence. + intros. + reflexivity. +Qed. + +Lemma is_neg_false : forall z, is_neg z = false -> (z_of_exp z >= 0)%Z. +Proof. + destruct z ; simpl ; try congruence. + destruct z ; try congruence. + compute. congruence. + compute. congruence. + generalize (Zle_0_nat n). auto with zarith. +Qed. + +Definition CInvR0 (r : Rcst) := Qeq_bool (Q_of_Rcst r) (0 # 1). + +Definition CPowR0 (z : Z) (r : Rcst) := + Z.ltb z Z0 && Qeq_bool (Q_of_Rcst r) (0 # 1). + Fixpoint R_of_Rcst (r : Rcst) : R := match r with | C0 => R0 | C1 => R1 | CZ z => IZR z - | CQ q => IQR q + | CQ q => Q2R q | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) + | CPow r1 z => + match z with + | inl z => + if CPowR0 z r1 + then R0 + else powerRZ (R_of_Rcst r1) z + | inr n => pow (R_of_Rcst r1) n + end | CInv r => - if Qeq_bool (Q_of_Rcst r) (0 # 1) - then R0 - else Rinv (R_of_Rcst r) - | COpp r => - (R_of_Rcst r) + if CInvR0 r then R0 + else Rinv (R_of_Rcst r) + | COpp r => - (R_of_Rcst r) end. -Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c. +Add Morphism Q2R with signature Qeq ==> @eq R as Q2R_m. + exact Qeq_eqR. +Qed. + +Lemma Q2R_pow_pos : forall q p, + Q2R (pow_pos Qmult q p) = pow_pos Rmult (Q2R q) p. +Proof. + induction p ; simpl;auto; + rewrite <- IHp; + repeat rewrite Q2R_mult; + reflexivity. +Qed. + +Lemma Q2R_pow_N : forall q n, + Q2R (pow_N 1%Q Qmult q n) = pow_N 1 Rmult (Q2R q) n. +Proof. + destruct n ; simpl. + - apply Q2R_1. + - apply Q2R_pow_pos. +Qed. + +Lemma Qmult_integral : forall q r, q * r == 0 -> q == 0 \/ r == 0. +Proof. + intros. + destruct (Qeq_dec q 0)%Q. + - left ; apply q0. + - apply Qmult_integral_l in H ; tauto. +Qed. + +Lemma Qpower_positive_eq_zero : forall q p, + Qpower_positive q p == 0 -> q == 0. +Proof. + unfold Qpower_positive. + induction p ; simpl; intros; + repeat match goal with + | H : _ * _ == 0 |- _ => + apply Qmult_integral in H; destruct H + end; tauto. +Qed. + +Lemma Qpower_positive_zero : forall p, + Qpower_positive 0 p == 0%Q. +Proof. + induction p ; simpl; + try rewrite IHp ; reflexivity. +Qed. + + +Lemma Q2RpowerRZ : + forall q z + (DEF : not (q == 0)%Q \/ (z >= Z0)%Z), + Q2R (q ^ z) = powerRZ (Q2R q) z. +Proof. + intros. + destruct Qpower_theory. + destruct R_power_theory. + unfold Qpower, powerRZ. + destruct z. + - apply Q2R_1. + - + change (Qpower_positive q p) + with (Qpower q (Zpos p)). + rewrite <- N2Z.inj_pos. + rewrite <- positive_N_nat. + rewrite rpow_pow_N. + rewrite rpow_pow_N0. + apply Q2R_pow_N. + - + rewrite Q2R_inv. + unfold Qpower_positive. + rewrite <- positive_N_nat. + rewrite rpow_pow_N0. + unfold pow_N. + rewrite Q2R_pow_pos. + auto. + intro. + apply Qpower_positive_eq_zero in H. + destruct DEF ; auto with arith. +Qed. + +Lemma Qpower0 : forall z, (z <> 0)%Z -> (0 ^ z == 0)%Q. Proof. - induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). - apply IQR_0. - apply IQR_1. + unfold Qpower. + destruct z;intros. + - congruence. + - apply Qpower_positive_zero. + - rewrite Qpower_positive_zero. reflexivity. - unfold IQR. simpl. rewrite Rinv_1. reflexivity. - apply Q2R_plus. - apply Q2R_minus. - apply Q2R_mult. - rewrite <- IHc. - apply IQR_inv_ext. - rewrite <- IHc. +Qed. + + +Lemma Q_of_RcstR : forall c, Q2R (Q_of_Rcst c) = R_of_Rcst c. +Proof. + induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). + - apply Q2R_0. + - apply Q2R_1. + - reflexivity. + - unfold Q2R. simpl. rewrite Rinv_1. reflexivity. + - apply Q2R_plus. + - apply Q2R_minus. + - apply Q2R_mult. + - destruct z. + destruct (CPowR0 z c) eqn:C; unfold CPowR0 in C. + + + rewrite andb_true_iff in C. + destruct C as (C1 & C2). + rewrite Z.ltb_lt in C1. + apply Qeq_bool_eq in C2. + rewrite C2. + simpl. + rewrite Qpower0 by auto with zarith. + apply Q2R_0. + + rewrite Q2RpowerRZ. + rewrite IHc. + reflexivity. + rewrite andb_false_iff in C. + destruct C. + simpl. apply Z.ltb_ge in H. + auto with zarith. + left ; apply Qeq_bool_neq; auto. + + simpl. + rewrite <- IHc. + destruct Qpower_theory. + rewrite <- nat_N_Z. + rewrite rpow_pow_N. + destruct R_power_theory. + rewrite <- (Nnat.Nat2N.id n) at 2. + rewrite rpow_pow_N0. + apply Q2R_pow_N. + - rewrite <- IHc. + unfold CInvR0. + apply Q2R_inv_ext. + - rewrite <- IHc. apply Q2R_opp. - Qed. +Qed. Require Import EnvRing. @@ -227,7 +389,7 @@ Definition Reval_formula' := eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. Definition QReval_formula := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat pow . + eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat pow . Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. Proof. @@ -242,12 +404,12 @@ Proof. Qed. Definition Qeval_nformula := - eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IQR. + eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt Q2R. Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. - exact (fun env d =>eval_nformula_dec Rsor IQR env d). + exact (fun env d =>eval_nformula_dec Rsor Q2R env d). Qed. Definition RWitness := Psatz Q. @@ -279,32 +441,41 @@ Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) - runsat rdeduce - Rnormalise Rnegate - RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst) f) w. + unit runsat rdeduce + (Rnormalise unit) (Rnegate unit) + RWitness (fun cl => RWeakChecker (List.map fst cl)) (map_bformula (map_Formula Q_of_Rcst) f) w. -Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. +Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf (Reval_formula env) f. Proof. intros f w. unfold RTautoChecker. intros TC env. - apply (tauto_checker_sound QReval_formula Qeval_nformula) with (env := env) in TC. - rewrite eval_f_map in TC. - rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. + apply tauto_checker_sound with (eval:=QReval_formula) (eval':= Qeval_nformula) (env := env) in TC. + - change (eval_f (fun x : Prop => x) (QReval_formula env)) + with + (eval_bf (QReval_formula env)) in TC. + rewrite eval_bf_map in TC. + unfold eval_bf in TC. + rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. intro. unfold QReval_formula. rewrite <- eval_formulaSC with (phiS := R_of_Rcst). rewrite Reval_formula_compat. tauto. intro. rewrite Q_of_RcstR. reflexivity. + - apply Reval_nformula_dec. - destruct t. + - destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). - now apply (cnf_normalise_correct Rsor QSORaddon). - intros. now apply (cnf_negate_correct Rsor QSORaddon). - intros t w0. - apply RWeakChecker_sound. + - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). + - now apply (cnf_normalise_correct Rsor QSORaddon). + - intros. now eapply (cnf_negate_correct Rsor QSORaddon); eauto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := Qeval_nformula env0). + eapply RWeakChecker_sound; eauto. + tauto. Qed. diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 952a1b91e7..898a3a1a28 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -36,6 +36,21 @@ trivial. intro; apply IH. Qed. + +Theorem make_impl_map : + forall (A B: Type) (eval : A -> Prop) (eval' : A*B -> Prop) (l : list (A*B)) r + (EVAL : forall x, eval' x <-> eval (fst x)), + make_impl eval' l r <-> make_impl eval (List.map fst l) r. +Proof. +induction l as [| a l IH]; simpl. +- tauto. +- intros. + rewrite EVAL. + rewrite IH. + tauto. + auto. +Qed. + Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := match l with | nil => True diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 782fab5e68..60931df517 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -81,30 +81,30 @@ Record SORaddon := mk_SOR_addon { Variable addon : SORaddon. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as micomega_sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. - exact sor.(SORle_wd). + exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. - exact sor.(SORlt_wd). + exact (SORlt_wd sor). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. @@ -124,12 +124,12 @@ Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. Proof. - exact addon.(SORcleb_morph). + exact (SORcleb_morph addon). Qed. Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. Proof. -intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. +intros x y H1. apply (SORcneqb_morph addon). unfold cneqb, negb in H1. destruct (ceqb x y); now try discriminate. Qed. @@ -325,9 +325,9 @@ Definition map_option2 (A B C : Type) (f : A -> B -> option C) Arguments map_option2 [A B C] f o o'. Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor). Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := let (ef,o) := f in @@ -368,8 +368,8 @@ Proof. destruct f. intros. destruct o ; inversion H0 ; try discriminate. simpl in *. unfold eval_pol in *. - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). + rewrite (Pmul_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). rewrite H. apply (Rtimes_0_r sor). Qed. @@ -385,8 +385,8 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Pmul_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); apply OpMult_sound with (3:= H);assumption. Qed. @@ -402,8 +402,8 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Padd_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Padd_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); apply OpAdd_sound with (3:= H);assumption. Qed. @@ -422,12 +422,12 @@ Proof. (* index is out-of-bounds *) inversion H0. rewrite Heq. simpl. - now apply addon.(SORrm).(morph0). + now apply (morph0 (SORrm addon)). (* PsatzSquare *) simpl. intros. inversion H0. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Psquare_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl. @@ -454,11 +454,11 @@ Proof. simpl. intro. case_eq (cO [<] c). intros. inversion H1. simpl. - rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. discriminate. (* PsatzZ *) simpl. intros. inversion H0. - simpl. apply addon.(SORrm).(morph0). + simpl. apply (morph0 (SORrm addon)). Qed. Fixpoint ge_bool (n m : nat) : bool := @@ -529,8 +529,8 @@ Proof. inv H. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + rewrite (Psquare_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl in *. @@ -570,12 +570,12 @@ Proof. case_eq (cO [<] c). intros. rewrite H1 in H. inv H. unfold eval_nformula. simpl. - rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. intros. rewrite H1 in H. discriminate. (* PsatzZ *) simpl in *. inv H. unfold eval_nformula. simpl. - apply addon.(SORrm).(morph0). + apply (morph0 (SORrm addon)). Qed. @@ -592,19 +592,19 @@ Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) - addon.(SORrm). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor) in + PsubC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) + (SORrm addon). Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := let Rops_wd := mk_reqe (*rplus rtimes ropp req*) - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) - addon.(SORrm). + (SORplus_wd sor) + (SORtimes_wd sor) + (SORopp_wd sor) in + PaddC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) + (SORrm addon). (* Check that a formula f is inconsistent by normalizing and comparing the @@ -631,9 +631,9 @@ intros p op H1 env. unfold check_inconsistent in H1. destruct op; simpl ; (*****) destruct p ; simpl; try discriminate H1; -try rewrite <- addon.(SORrm).(morph0); trivial. +try rewrite <- (morph0 (SORrm addon)); trivial. now apply cneqb_sound. -apply addon.(SORrm).(morph_eq) in H1. congruence. +apply (morph_eq (SORrm addon)) in H1. congruence. apply cleb_sound in H1. now apply -> (Rle_ngt sor). apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. @@ -706,6 +706,8 @@ Definition psub := Psub cO cplus cminus copp ceqb. Definition padd := Padd cO cplus ceqb. +Definition pmul := Pmul cO cI cplus ctimes ceqb. + Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in @@ -736,21 +738,30 @@ let (lhs, op, rhs) := f in Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. - apply (Psub_ok sor.(SORsetoid) Rops_wd - (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). + apply (Psub_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. Proof. intros. - apply (Padd_ok sor.(SORsetoid) Rops_wd + apply (Padd_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). +Qed. + +Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) == eval_pol env lhs * eval_pol env rhs. +Proof. + intros. + apply (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. + + Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). Proof. intros. - apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). + apply (norm_aux_spec (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon) (SORpower addon) ). Qed. @@ -801,29 +812,29 @@ Definition xnormalise (t:Formula C) : list (NFormula) := Import Coq.micromega.Tauto. -Definition cnf_normalise (t:Formula C) : cnf (NFormula) := - List.map (fun x => x::nil) (xnormalise t). +Definition cnf_normalise {T : Type} (t:Formula C) (tg : T) : cnf NFormula T := + List.map (fun x => (x,tg)::nil) (xnormalise t). -Add Ring SORRing : sor.(SORrt). +Add Ring SORRing : (SORrt sor). -Lemma cnf_normalise_correct : forall env t, eval_cnf eval_nformula env (cnf_normalise t) -> eval_formula env t. +Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) -> eval_formula env t. Proof. - unfold cnf_normalise, xnormalise ; simpl ; intros env t. + unfold cnf_normalise, xnormalise ; simpl ; intros T env t tg. unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; simpl; + destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; + simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. - (**) - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - now rewrite <- (Rminus_eq_0 sor). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + - apply (SORle_antisymm sor). + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + - now rewrite <- (Rminus_eq_0 sor). + - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. Qed. Definition xnegate (t:Formula C) : list (NFormula) := @@ -839,30 +850,27 @@ Definition xnegate (t:Formula C) : list (NFormula) := | OpLe => (psub rhs lhs,NonStrict) :: nil end. -Definition cnf_negate (t:Formula C) : cnf (NFormula) := - List.map (fun x => x::nil) (xnegate t). +Definition cnf_negate {T : Type} (t:Formula C) (tg:T) : cnf NFormula T := + List.map (fun x => (x,tg)::nil) (xnegate t). -Lemma cnf_negate_correct : forall env t, eval_cnf eval_nformula env (cnf_negate t) -> ~ eval_formula env t. +Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) -> ~ eval_formula env t. Proof. - unfold cnf_negate, xnegate ; simpl ; intros env t. + unfold cnf_negate, xnegate ; simpl ; intros T env t tg. unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; simpl; + destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. - (**) + - apply H0. rewrite H1 ; ring. - (**) - apply H1. - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - (**) - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + - apply H1. apply (SORle_antisymm sor). + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + - apply H0. now rewrite (Rle_le_minus sor) in H1. + - apply H0. now rewrite (Rle_le_minus sor) in H1. + - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + - apply H0. now rewrite (Rlt_lt_minus sor) in H1. Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). @@ -912,7 +920,7 @@ Proof. unfold Env.nth. unfold jump at 2. rewrite <- Pos.add_1_l. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite (rpow_pow_N (SORpower addon)). unfold pow_N. ring. Qed. @@ -932,7 +940,7 @@ Proof. unfold Env.tail. rewrite xdenorm_correct. change (Pos.succ xH) with 2%positive. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite (rpow_pow_N (SORpower addon)). simpl. reflexivity. Qed. diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 587f2f1fa4..7b9b88c0fe 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -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-20019 *) (* *) (************************************************************************) @@ -21,176 +21,363 @@ Require Import Bool. Set Implicit Arguments. +Section S. + Context {TA : Type}. (* type of interpreted atoms *) + Context {TX : Type}. (* type of uninterpreted terms (Prop) *) + Context {AA : Type}. (* type of annotations for atoms *) + Context {AF : Type}. (* type of formulae identifiers *) + #[universes(template)] - Inductive BFormula (A:Type) : Type := - | TT : BFormula A - | FF : BFormula A - | X : Prop -> BFormula A - | A : A -> BFormula A - | Cj : BFormula A -> BFormula A -> BFormula A - | D : BFormula A-> BFormula A -> BFormula A - | N : BFormula A -> BFormula A - | I : BFormula A-> BFormula A-> BFormula A. - - Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := - match f with - | TT _ => True - | FF _ => False - | A a => ev a - | X _ p => p - | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) - | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) - | N e => ~ (eval_f ev e) - | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) - end. + Inductive GFormula : Type := + | TT : GFormula + | FF : GFormula + | X : TX -> GFormula + | A : TA -> AA -> GFormula + | Cj : GFormula -> GFormula -> GFormula + | D : GFormula -> GFormula -> GFormula + | N : GFormula -> GFormula + | I : GFormula -> option AF -> GFormula -> GFormula. + + Section MAPX. + Variable F : TX -> TX. + + Fixpoint mapX (f : GFormula) : GFormula := + match f with + | TT => TT + | FF => FF + | X x => X (F x) + | A a an => A a an + | Cj f1 f2 => Cj (mapX f1) (mapX f2) + | D f1 f2 => D (mapX f1) (mapX f2) + | N f => N (mapX f) + | I f1 o f2 => I (mapX f1) o (mapX f2) + end. - Lemma eval_f_morph : forall A (ev ev' : A -> Prop) (f : BFormula A), - (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). - Proof. - induction f ; simpl ; try tauto. - intros. - assert (H' := H a). - auto. - Qed. + End MAPX. + + Section FOLDANNOT. + Variable ACC : Type. + Variable F : ACC -> AA -> ACC. + + Fixpoint foldA (f : GFormula) (acc : ACC) : ACC := + match f with + | TT => acc + | FF => acc + | X x => acc + | A a an => F acc an + | Cj f1 f2 + | D f1 f2 + | I f1 _ f2 => foldA f1 (foldA f2 acc) + | N f => foldA f acc + end. + End FOLDANNOT. - Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U := + Definition cons_id (id : option AF) (l : list AF) := + match id with + | None => l + | Some id => id :: l + end. + + Fixpoint ids_of_formula f := match f with - | TT _ => TT _ - | FF _ => FF _ - | X _ p => X _ p - | A a => A (fct a) - | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) - | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) - | N f => N (map_bformula fct f) - | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2) + | I f id f' => cons_id id (ids_of_formula f') + | _ => nil end. - Lemma eval_f_map : forall T U (fct: T-> U) env f , - eval_f env (map_bformula fct f) = eval_f (fun x => env (fct x)) f. - Proof. - induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. - rewrite <- IHf. auto. - Qed. + Fixpoint collect_annot (f : GFormula) : list AA := + match f with + | TT | FF | X _ => nil + | A _ a => a ::nil + | Cj f1 f2 + | D f1 f2 + | I f1 _ f2 => collect_annot f1 ++ collect_annot f2 + | N f => collect_annot f + end. + Variable ex : TX -> Prop. (* [ex] will be the identity *) + Section EVAL. - Lemma map_simpl : forall A B f l, @map A B f l = match l with - | nil => nil - | a :: l=> (f a) :: (@map A B f l) - end. + Variable ea : TA -> Prop. + + Fixpoint eval_f (f:GFormula) {struct f}: Prop := + match f with + | TT => True + | FF => False + | A a _ => ea a + | X p => ex p + | Cj e1 e2 => (eval_f e1) /\ (eval_f e2) + | D e1 e2 => (eval_f e1) \/ (eval_f e2) + | N e => ~ (eval_f e) + | I f1 _ f2 => (eval_f f1) -> (eval_f f2) + end. + + + End EVAL. + + + + + + Lemma eval_f_morph : + forall (ev ev' : TA -> Prop) (f : GFormula), + (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). Proof. - destruct l ; reflexivity. + induction f ; simpl ; try tauto. + intros. + apply H. Qed. +End S. - Section S. - Variable Env : Type. - Variable Term : Type. - Variable eval : Env -> Term -> Prop. - Variable Term' : Type. - Variable eval' : Env -> Term' -> Prop. +(** Typical boolean formulae *) +Definition BFormula (A : Type) := @GFormula A Prop unit unit. +Section MAPATOMS. + Context {TA TA':Type}. + Context {TX : Type}. + Context {AA : Type}. + Context {AF : Type}. - Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). +Fixpoint map_bformula (fct : TA -> TA') (f : @GFormula TA TX AA AF ) : @GFormula TA' TX AA AF := + match f with + | TT => TT + | FF => FF + | X p => X p + | A a t => A (fct a) t + | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) + | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) + | N f => N (map_bformula fct f) + | I f1 a f2 => I (map_bformula fct f1) a (map_bformula fct f2) + end. - Variable unsat : Term' -> bool. +End MAPATOMS. - Variable unsat_prop : forall t, unsat t = true -> - forall env, eval' env t -> False. +Lemma map_simpl : forall A B f l, @map A B f l = match l with + | nil => nil + | a :: l=> (f a) :: (@map A B f l) + end. +Proof. + destruct l ; reflexivity. +Qed. - Variable deduce : Term' -> Term' -> option Term'. - Variable deduce_prop : forall env t t' u, - eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. +Section S. + (** A cnf tracking annotations of atoms. *) + + (** Type parameters *) + Variable Env : Type. + Variable Term : Type. + Variable Term' : Type. + Variable Annot : Type. + + Variable unsat : Term' -> bool. (* see [unsat_prop] *) + Variable deduce : Term' -> Term' -> option Term'. (* see [deduce_prop] *) - Definition clause := list Term'. - Definition cnf := list clause. + Definition clause := list (Term' * Annot). + Definition cnf := list clause. - Variable normalise : Term -> cnf. - Variable negate : Term -> cnf. + Variable normalise : Term -> Annot -> cnf. + Variable negate : Term -> Annot -> cnf. - Definition tt : cnf := @nil clause. - Definition ff : cnf := cons (@nil Term') nil. + Definition cnf_tt : cnf := @nil clause. + Definition cnf_ff : cnf := cons (@nil (Term' * Annot)) nil. + (** Our cnf is optimised and detects contradictions on the fly. *) - Fixpoint add_term (t: Term') (cl : clause) : option clause := + Fixpoint add_term (t: Term' * Annot) (cl : clause) : option clause := match cl with - | nil => - match deduce t t with - | None => Some (t ::nil) - | Some u => if unsat u then None else Some (t::nil) - end - | t'::cl => - match deduce t t' with - | None => - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end - | Some u => - if unsat u then None else - match add_term t cl with - | None => None - | Some cl' => Some (t' :: cl') - end + | nil => + match deduce (fst t) (fst t) with + | None => Some (t ::nil) + | Some u => if unsat u then None else Some (t::nil) + end + | t'::cl => + match deduce (fst t) (fst t') with + | None => + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') end + | Some u => + if unsat u then None else + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') + end + end end. Fixpoint or_clause (cl1 cl2 : clause) : option clause := match cl1 with - | nil => Some cl2 - | t::cl => match add_term t cl2 with - | None => None - | Some cl' => or_clause cl cl' - end + | nil => Some cl2 + | t::cl => match add_term t cl2 with + | None => None + | Some cl' => or_clause cl cl' + end end. -(* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.map (fun x => (t++x)) f. *) + (* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := + List.map (fun x => (t++x)) f. *) Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.fold_right (fun e acc => - match or_clause t e with - | None => acc - | Some cl => cl :: acc - end) nil f. + List.fold_right (fun e acc => + match or_clause t e with + | None => acc + | Some cl => cl :: acc + end) nil f. Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with - | nil => tt - | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') + | nil => cnf_tt + | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') end. Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := f1 ++ f2. - Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := + (** TX is Prop in Coq and EConstr.constr in Ocaml. + AF i s unit in Coq and Names.Id.t in Ocaml + *) + Definition TFormula (TX: Type) (AF: Type) := @GFormula Term TX Annot AF. + + Fixpoint xcnf {TX AF: Type} (pol : bool) (f : TFormula TX AF) {struct f}: cnf := match f with - | TT _ => if pol then tt else ff - | FF _ => if pol then ff else tt - | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) - | A x => if pol then normalise x else negate x - | N e => xcnf (negb pol) e - | Cj e1 e2 => - (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) + | TT => if pol then cnf_tt else cnf_ff + | FF => if pol then cnf_ff else cnf_tt + | X p => if pol then cnf_ff else cnf_ff (* This is not complete - cannot negate any proposition *) + | A x t => if pol then normalise x t else negate x t + | N e => xcnf (negb pol) e + | Cj e1 e2 => + (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) + | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) + | I e1 _ e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) end. - Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval' env) cl. + Section CNFAnnot. + + (** Records annotations used to optimise the cnf. + Those need to be kept when pruning the formula. + For efficiency, this is a separate function. + *) + + + + Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + list Annot := + match cl with + | nil => (* if t is unsat, the clause is empty BUT t is needed. *) + match deduce (fst t) (fst t) with + | Some u => if unsat u then inr ((snd t)::nil) else inl (t::nil) + | None => inl (t::nil) + end + | t'::cl => (* if t /\ t' is unsat, the clause is empty BUT t & t' are needed *) + match deduce (fst t) (fst t') with + | Some u => if unsat u then inr ((snd t)::(snd t')::nil) + else match radd_term t cl with + | inl cl' => inl (t'::cl') + | inr l => inr l + end + | None => match radd_term t cl with + | inl cl' => inl (t'::cl') + | inr l => inr l + end + end + end. + + Fixpoint ror_clause cl1 cl2 := + match cl1 with + | nil => inl cl2 + | t::cl => match radd_term t cl2 with + | inl cl' => ror_clause cl cl' + | inr l => inr l + end + end. + + Definition ror_clause_cnf t f := + List.fold_right (fun e '(acc,tg) => + match ror_clause t e with + | inl cl => (cl :: acc,tg) + | inr l => (acc,tg++l) + end) (nil,nil) f . + + + Fixpoint ror_cnf f f' := + match f with + | nil => (cnf_tt,nil) + | e :: rst => + let (rst_f',t) := ror_cnf rst f' in + let (e_f', t') := ror_clause_cnf e f' in + (rst_f' ++ e_f', t ++ t') + end. + + Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) := + match f with + | TT => if polarity then (cnf_tt,nil) else (cnf_ff,nil) + | FF => if polarity then (cnf_ff,nil) else (cnf_tt,nil) + | X p => if polarity then (cnf_ff,nil) else (cnf_ff,nil) + | A x t => ((if polarity then normalise x t else negate x t),nil) + | N e => rxcnf (negb polarity) e + | Cj e1 e2 => + let (e1,t1) := rxcnf polarity e1 in + let (e2,t2) := rxcnf polarity e2 in + if polarity + then (e1 ++ e2, t1 ++ t2) + else let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + | D e1 e2 => + let (e1,t1) := rxcnf polarity e1 in + let (e2,t2) := rxcnf polarity e2 in + if polarity + then let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + else (e1 ++ e2, t1 ++ t2) + | I e1 _ e2 => + let (e1 , t1) := (rxcnf (negb polarity) e1) in + let (e2 , t2) := (rxcnf polarity e2) in + if polarity + then let (f',t') := ror_cnf e1 e2 in + (f', t1 ++ t2 ++ t') + else (and_cnf e1 e2, t1 ++ t2) + end. + + End CNFAnnot. + + + + Variable eval : Env -> Term -> Prop. + + Variable eval' : Env -> Term' -> Prop. + + Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). + + + Variable unsat_prop : forall t, unsat t = true -> + forall env, eval' env t -> False. + + + + Variable deduce_prop : forall env t t' u, + eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. + + + + Definition eval_tt (env : Env) (tt : Term' * Annot) := eval' env (fst tt). + + + Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval_tt env) cl. Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. - + Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. Proof. unfold eval_cnf. @@ -201,97 +388,107 @@ Set Implicit Arguments. Definition eval_opt_clause (env : Env) (cl: option clause) := match cl with - | None => True - | Some cl => eval_clause env cl + | None => True + | Some cl => eval_clause env cl end. - Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). - Proof. - induction cl. - (* BC *) - simpl. - case_eq (deduce t t) ; auto. - intros *. - case_eq (unsat t0) ; auto. - unfold eval_clause. - rewrite make_conj_cons. - intros. intro. - apply unsat_prop with (1:= H) (env := env). - apply deduce_prop with (3:= H0) ; tauto. - (* IC *) - simpl. - case_eq (deduce t a). - intro u. - case_eq (unsat u). - simpl. intros. - unfold eval_clause. - intro. - apply unsat_prop with (1:= H) (env:= env). - repeat rewrite make_conj_cons in H2. - apply deduce_prop with (3:= H0); tauto. - intro. - case_eq (add_term t cl) ; intros. - simpl in H2. - rewrite H0 in IHcl. - simpl in IHcl. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - rewrite H0 in IHcl ; simpl in *. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - case_eq (add_term t cl) ; intros. - simpl in H1. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - rewrite H in IHcl. - simpl in IHcl. - tauto. - simpl in *. - rewrite H in IHcl. - simpl in IHcl. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. - Qed. - - - Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). Proof. induction cl. - simpl. tauto. + - (* BC *) + simpl. + case_eq (deduce (fst t) (fst t)) ; auto. intros *. + case_eq (unsat t0) ; auto. + unfold eval_clause. + rewrite make_conj_cons. + intros. intro. + apply unsat_prop with (1:= H) (env := env). + apply deduce_prop with (3:= H0) ; tauto. + - (* IC *) simpl. - assert (HH := add_term_correct env a cl'). - case_eq (add_term a cl'). - simpl in *. + case_eq (deduce (fst t) (fst a)). + intro u. + case_eq (unsat u). + simpl. intros. + unfold eval_clause. + intro. + apply unsat_prop with (1:= H) (env:= env). + repeat rewrite make_conj_cons in H2. + apply deduce_prop with (3:= H0); tauto. + intro. + case_eq (add_term t cl) ; intros. + simpl in H2. + rewrite H0 in IHcl. + simpl in IHcl. + unfold eval_clause in *. intros. - apply IHcl in H0. - rewrite H in HH. - simpl in HH. + repeat rewrite make_conj_cons in *. + tauto. + rewrite H0 in IHcl ; simpl in *. unfold eval_clause in *. - destruct H0. + intros. repeat rewrite make_conj_cons in *. tauto. - apply HH in H0. - apply not_make_conj_cons in H0 ; auto. + case_eq (add_term t cl) ; intros. + simpl in H1. + unfold eval_clause in *. repeat rewrite make_conj_cons in *. + rewrite H in IHcl. + simpl in IHcl. tauto. - simpl. - intros. - rewrite H in HH. - simpl in HH. + simpl in *. + rewrite H in IHcl. + simpl in IHcl. unfold eval_clause in *. - assert (HH' := HH Coq.Init.Logic.I). - apply not_make_conj_cons in HH'; auto. repeat rewrite make_conj_cons in *. tauto. Qed. - + + + Lemma no_middle_eval_tt : forall env a, + eval_tt env a \/ ~ eval_tt env a. + Proof. + unfold eval_tt. + auto. + Qed. + + Hint Resolve no_middle_eval_tt : tauto. + + Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Proof. + induction cl. + - simpl. tauto. + - intros *. + simpl. + assert (HH := add_term_correct env a cl'). + case_eq (add_term a cl'). + + + intros. + apply IHcl in H0. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + destruct H0. + * + repeat rewrite make_conj_cons in *. + tauto. + * apply HH in H0. + apply not_make_conj_cons in H0 ; auto with tauto. + repeat rewrite make_conj_cons in *. + tauto. + + + intros. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + assert (HH' := HH Coq.Init.Logic.I). + apply not_make_conj_cons in HH'; auto with tauto. + repeat rewrite make_conj_cons in *. + tauto. + Qed. + Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). Proof. @@ -299,39 +496,38 @@ Set Implicit Arguments. unfold or_clause_cnf. intros until t. set (F := (fun (e : clause) (acc : list clause) => - match or_clause t e with - | Some cl => cl :: acc - | None => acc - end)). - induction f. - auto. - (**) + match or_clause t e with + | Some cl => cl :: acc + | None => acc + end)). + induction f;auto. simpl. intros. destruct f. - simpl in H. - simpl in IHf. - unfold F in H. - revert H. - intros. - apply or_clause_correct. - destruct (or_clause t a) ; simpl in * ; auto. - unfold F in H at 1. - revert H. - assert (HH := or_clause_correct t a env). - destruct (or_clause t a); simpl in HH ; - rewrite make_conj_cons in * ; intuition. - rewrite make_conj_cons in *. - tauto. + - simpl in H. + simpl in IHf. + unfold F in H. + revert H. + intros. + apply or_clause_correct. + destruct (or_clause t a) ; simpl in * ; auto. + - + unfold F in H at 1. + revert H. + assert (HH := or_clause_correct t a env). + destruct (or_clause t a); simpl in HH ; + rewrite make_conj_cons in * ; intuition. + rewrite make_conj_cons in *. + tauto. Qed. - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f). - Proof. - intros. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - Qed. + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a) -> eval_cnf env f -> eval_cnf env (a::f). + Proof. + intros. + unfold eval_cnf in *. + rewrite make_conj_cons ; eauto. + Qed. Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). Proof. @@ -352,12 +548,11 @@ Set Implicit Arguments. right ; auto. Qed. - Variable normalise_correct : forall env t, eval_cnf env (normalise t) -> eval env t. - - Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t. + Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t. + Variable negate_correct : forall env t tg, eval_cnf env (negate t tg) -> ~ eval env t. - Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). + Lemma xcnf_correct : forall (f : @GFormula Term Prop Annot unit) pol env, eval_cnf env (xcnf pol f) -> eval_f (fun x => x) (eval env) (if pol then f else N f). Proof. induction f. (* TT *) @@ -385,10 +580,10 @@ Set Implicit Arguments. simpl. destruct pol ; simpl. intros. - apply normalise_correct ; auto. + eapply normalise_correct ; eauto. (* A 2 *) intros. - apply negate_correct ; auto. + eapply negate_correct ; eauto. auto. (* Cj *) destruct pol ; simpl. @@ -462,21 +657,21 @@ Set Implicit Arguments. Variable Witness : Type. - Variable checker : list Term' -> Witness -> bool. + Variable checker : list (Term'*Annot) -> Witness -> bool. - Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. + Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval_tt env) t False. Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := match f with - | nil => true - | e::f => match l with - | nil => false - | c::l => match checker e c with - | true => cnf_checker f l - | _ => false - end - end - end. + | nil => true + | e::f => match l with + | nil => false + | c::l => match checker e c with + | true => cnf_checker f l + | _ => false + end + end + end. Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. @@ -501,22 +696,32 @@ Set Implicit Arguments. Qed. - Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := + Definition tauto_checker (f:@GFormula Term Prop Annot unit) (w:list Witness) : bool := cnf_checker (xcnf true f) w. - Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. + Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (fun x => x) (eval env) t. Proof. unfold tauto_checker. intros. - change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). + change (eval_f (fun x => x) (eval env) t) with (eval_f (fun x => x) (eval env) (if true then t else TT)). apply (xcnf_correct t true). eapply cnf_checker_sound ; eauto. Qed. + Definition eval_bf {A : Type} (ea : A -> Prop) (f: BFormula A) := eval_f (fun x => x) ea f. + + + Lemma eval_bf_map : forall T U (fct: T-> U) env f , + eval_bf env (map_bformula fct f) = eval_bf (fun x => env (fct x)) f. +Proof. + induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. + rewrite <- IHf. auto. +Qed. End S. + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index c888f9af45..8148c7033c 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -33,14 +33,14 @@ Section MakeVarMap. #[universes(template)] Inductive t : Type := | Empty : t - | Leaf : A -> t - | Node : t -> A -> t -> t . + | Elt : A -> t + | Branch : t -> A -> t -> t . Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with | Empty => default - | Leaf i => i - | Node l e r => match p with + | Elt i => i + | Branch l e r => match p with | xH => e | xO p => find l p | xI p => find r p @@ -50,25 +50,25 @@ Section MakeVarMap. Fixpoint singleton (x:positive) (v : A) : t := match x with - | xH => Leaf v - | xO p => Node (singleton p v) default Empty - | xI p => Node Empty default (singleton p v) + | xH => Elt v + | xO p => Branch (singleton p v) default Empty + | xI p => Branch Empty default (singleton p v) end. Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := match m with | Empty => singleton x v - | Leaf vl => + | Elt vl => match x with - | xH => Leaf v - | xO p => Node (singleton p v) vl Empty - | xI p => Node Empty vl (singleton p v) + | xH => Elt v + | xO p => Branch (singleton p v) vl Empty + | xI p => Branch Empty vl (singleton p v) end - | Node l o r => + | Branch l o r => match x with - | xH => Node l v r - | xI p => Node l o (vm_add p v r) - | xO p => Node (vm_add p v l) o r + | xH => Branch l v r + | xI p => Branch l o (vm_add p v r) + | xO p => Branch (vm_add p v l) o r end end. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index 137453a9ed..9ff6850fdf 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -43,48 +43,48 @@ Notation "x < y" := (rlt x y). Lemma req_refl : forall x, req x x. Proof. - destruct sor.(SORsetoid) as (Equivalence_Reflexive,_,_). + destruct (SORsetoid sor) as (Equivalence_Reflexive,_,_). apply Equivalence_Reflexive. Qed. Lemma req_sym : forall x y, req x y -> req y x. Proof. - destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_). + destruct (SORsetoid sor) as (_,Equivalence_Symmetric,_). apply Equivalence_Symmetric. Qed. Lemma req_trans : forall x y z, req x y -> req y z -> req x z. Proof. - destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive). + destruct (SORsetoid sor) as (_,_,Equivalence_Transitive). apply Equivalence_Transitive. Qed. Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor)) + symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor)) + transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor)) as sor_setoid. Add Morphism rplus with signature req ==> req ==> req as rplus_morph. Proof. -exact sor.(SORplus_wd). +exact (SORplus_wd sor). Qed. Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. Proof. -exact sor.(SORtimes_wd). +exact (SORtimes_wd sor). Qed. Add Morphism ropp with signature req ==> req as ropp_morph. Proof. -exact sor.(SORopp_wd). +exact (SORopp_wd sor). Qed. Add Morphism rle with signature req ==> req ==> iff as rle_morph. Proof. -exact sor.(SORle_wd). +exact (SORle_wd sor). Qed. Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. Proof. -exact sor.(SORlt_wd). +exact (SORlt_wd sor). Qed. Add Morphism rminus with signature req ==> req ==> req as rminus_morph. Proof. @@ -115,7 +115,7 @@ Lemma Zring_morph : 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool gen_order_phi_Z. Proof. -exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). +exact (gen_phiZ_morph (SORsetoid sor) ring_ops_wd (SORrt sor)). Qed. Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. @@ -127,8 +127,8 @@ Qed. Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. Proof. -exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd - (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). +exact (ARgen_phiPOS_Psucc (SORsetoid sor) ring_ops_wd + (Rth_ARth (SORsetoid sor) ring_ops_wd (SORrt sor))). Qed. Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. @@ -142,7 +142,7 @@ Qed. Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. Proof. intros x y H. -do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); +do 2 rewrite (same_genZ (SORsetoid sor) ring_ops_wd (SORrt sor)); destruct x; destruct y; simpl in *; try discriminate. apply phi_pos1_pos. now apply clt_pos_morph. @@ -157,7 +157,7 @@ Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. Proof. unfold Z.leb; intros x y H. case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. -le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. +le_equal. apply (morph_eq Zring_morph). unfold Zeq_bool; now rewrite H1. le_less. now apply clt_morph. discriminate. Qed. @@ -172,5 +172,3 @@ apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. Qed. End InitialMorphism. - - diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index f341a04e03..ab218a1778 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -14,13 +14,14 @@ (* *) (************************************************************************) +Require Import List. +Require Import Bool. Require Import OrderedRing. Require Import RingMicromega. +Require FSetPositive FSetEqProperties. Require Import ZCoeff. Require Import Refl. Require Import ZArith. -Require Import List. -Require Import Bool. (*Declare ML Module "micromega_plugin".*) Ltac flatten_bool := @@ -162,6 +163,8 @@ Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. +Definition pmul := pmul 0 1 Z.add Z.mul Zeq_bool. + Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. Declare Equivalent Keys normZ RingMicromega.norm. @@ -180,6 +183,13 @@ Proof. apply (eval_pol_add Zsor ZSORaddon). Qed. +Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul lhs rhs) = eval_pol env lhs * eval_pol env rhs. +Proof. + intros. + apply (eval_pol_mul Zsor ZSORaddon). +Qed. + + Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . Proof. intros. @@ -202,13 +212,13 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) := Require Import Coq.micromega.Tauto BinNums. -Definition normalise (t:Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnormalise t). +Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + List.map (fun x => (x,tg)::nil) (xnormalise t). -Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t. +Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env t. Proof. - unfold normalise, xnormalise; cbn -[padd]; intros env t. + unfold normalise, xnormalise; cbn -[padd]; intros T env t tg. rewrite Zeval_formula_compat. unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o; cbn -[padd]; @@ -236,18 +246,18 @@ Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := | OpLe => (psub rhs lhs,NonStrict) :: nil end. -Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnegate t). +Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + List.map (fun x => (x,tg)::nil) (xnegate t). -Lemma negate_correct : forall env t, eval_cnf eval_nformula env (negate t) <-> ~ Zeval_formula env t. +Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. Proof. Proof. Opaque padd. - intros env t. + intros T env t tg. rewrite Zeval_formula_compat. unfold negate, xnegate ; simpl. unfold eval_cnf,eval_clause. - destruct t as [lhs o rhs]; case_eq o; simpl; + destruct t as [lhs o rhs]; case_eq o; unfold eval_tt ; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; @@ -264,9 +274,11 @@ Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. +Definition cnfZ (Annot TX AF : Type) (f : TFormula (Formula Z) Annot TX AF) := + rxcnf Zunsat Zdeduce normalise negate true f. Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := - @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZWitness ZWeakChecker f w. + @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. (* To get a complete checker, the proof format has to be enriched *) @@ -326,7 +338,9 @@ Inductive ZArithProof := | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof | EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*). +(*| ExProof : positive -> positive -> positive -> ZArithProof ExProof z t x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) +. +(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) @@ -600,6 +614,186 @@ Definition valid_cut_sign (op:Op1) := | _ => false end. +Module Vars. + Import FSetPositive. + Include PositiveSet. + + Module Facts := FSetEqProperties.EqProperties(PositiveSet). + + Lemma mem_union_l : forall x s s', + mem x s = true -> + mem x (union s s') = true. + Proof. + intros. + rewrite Facts.union_mem. + rewrite H. reflexivity. + Qed. + + Lemma mem_union_r : forall x s s', + mem x s' = true -> + mem x (union s s') = true. + Proof. + intros. + rewrite Facts.union_mem. + rewrite H. rewrite orb_comm. reflexivity. + Qed. + + Lemma mem_singleton : forall p, + mem p (singleton p) = true. + Proof. + apply Facts.singleton_mem_1. + Qed. + + Lemma mem_elements : forall x v, + mem x v = true <-> List.In x (PositiveSet.elements v). + Proof. + intros. + rewrite Facts.MP.FM.elements_b. + rewrite existsb_exists. + unfold Facts.MP.FM.eqb. + split ; intros. + - destruct H as (x' & IN & EQ). + destruct (PositiveSet.E.eq_dec x x') ; try congruence. + subst ; auto. + - exists x. + split ; auto. + destruct (PositiveSet.E.eq_dec x x) ; congruence. + Qed. + + Definition max_element (vars : t) := + fold Pos.max vars xH. + + Lemma max_element_max : + forall x vars, mem x vars = true -> Pos.le x (max_element vars). + Proof. + unfold max_element. + intros. + rewrite mem_elements in H. + rewrite PositiveSet.fold_1. + set (F := (fun (a : positive) (e : PositiveSet.elt) => Pos.max e a)). + revert H. + assert (((x <= 1 -> x <= fold_left F (PositiveSet.elements vars) 1) + /\ + (List.In x (PositiveSet.elements vars) -> + x <= fold_left F (PositiveSet.elements vars) 1))%positive). + { + revert x. + generalize xH as acc. + induction (PositiveSet.elements vars). + - simpl. tauto. + - simpl. + intros. + destruct (IHl (F acc a) x). + split ; intros. + apply H. + unfold F. + rewrite Pos.max_le_iff. + tauto. + destruct H1 ; subst. + apply H. + unfold F. + rewrite Pos.max_le_iff. + simpl. + left. + apply Pos.le_refl. + tauto. + } + tauto. + Qed. + + Definition is_subset (v1 v2 : t) := + forall x, mem x v1 = true -> mem x v2 = true. + + Lemma is_subset_union_l : forall v1 v2, + is_subset v1 (union v1 v2). + Proof. + unfold is_subset. + intros. + apply mem_union_l; auto. + Qed. + + Lemma is_subset_union_r : forall v1 v2, + is_subset v1 (union v2 v1). + Proof. + unfold is_subset. + intros. + apply mem_union_r; auto. + Qed. + + + End Vars. + + +Fixpoint vars_of_pexpr (e : PExpr Z) : Vars.t := + match e with + | PEc _ => Vars.empty + | PEX _ x => Vars.singleton x + | PEadd e1 e2 | PEsub e1 e2 | PEmul e1 e2 => + let v1 := vars_of_pexpr e1 in + let v2 := vars_of_pexpr e2 in + Vars.union v1 v2 + | PEopp c => vars_of_pexpr c + | PEpow e n => vars_of_pexpr e + end. + +Definition vars_of_formula (f : Formula Z) := + match f with + | Build_Formula l o r => + let v1 := vars_of_pexpr l in + let v2 := vars_of_pexpr r in + Vars.union v1 v2 + end. + +Fixpoint vars_of_bformula {TX : Type} {TG : Type} {ID : Type} + (F : @GFormula (Formula Z) TX TG ID) : Vars.t := + match F with + | TT => Vars.empty + | FF => Vars.empty + | X p => Vars.empty + | A a t => vars_of_formula a + | Cj f1 f2 | D f1 f2 | I f1 _ f2 => + let v1 := vars_of_bformula f1 in + let v2 := vars_of_bformula f2 in + Vars.union v1 v2 + | Tauto.N f => vars_of_bformula f + end. + +Definition bound_var (v : positive) : Formula Z := + Build_Formula (PEX _ v) OpGe (PEc 0). + +Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := + Build_Formula (PEX _ x) OpEq (PEsub (PEX _ y) (PEX _ t)). + +Section BOUND. + Context {TX TG ID : Type}. + + Variable tag_of_var : positive -> positive -> option bool -> TG. + + Definition bound_vars (fr : positive) + (v : Vars.t) : @GFormula (Formula Z) TX TG ID := + Vars.fold (fun k acc => + let y := (xO (fr + k)) in + let z := (xI (fr + k)) in + Cj + (Cj (A (mk_eq_pos k y z) (tag_of_var fr k None)) + (Cj (A (bound_var y) (tag_of_var fr k (Some false))) + (A (bound_var z) (tag_of_var fr k (Some true))))) + acc) v TT. + + Definition bound_problem (F : @GFormula (Formula Z) TX TG ID) : GFormula := + let v := vars_of_bformula F in + I (bound_vars (Pos.succ (Vars.max_element v)) v) None F. + + + Definition bound_problem_fr (fr : positive) (F : @GFormula (Formula Z) TX TG ID) : GFormula := + let v := vars_of_bformula F in + I (bound_vars fr v) None F. + + +End BOUND. + + + Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with | DoneProof => false @@ -619,6 +813,10 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool : | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end +(* | SplitProof e pf1 pf2 => + match ZChecker ((e,NonStrict)::l) pf1 , ZChecker (( +*) + | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with | Some f1 , Some f2 => @@ -993,26 +1191,299 @@ Proof. apply genCuttingPlaneNone with (2:= H2) ; auto. Qed. + + Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := - @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZArithProof ZChecker f w. + @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZArithProof (fun cl => ZChecker (List.map fst cl)) f w. -Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. +Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (fun x => x) (Zeval_formula env) f. Proof. intros f w. unfold ZTautoChecker. - apply (tauto_checker_sound Zeval_formula eval_nformula). - apply Zeval_nformula_dec. - intros until env. + apply tauto_checker_sound with (eval' := eval_nformula). + - apply Zeval_nformula_dec. + - intros until env. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). - intros env t. - rewrite normalise_correct ; auto. - intros env t. - rewrite negate_correct ; auto. - intros t w0. - apply ZChecker_sound. + - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). + - + intros env t tg. + rewrite normalise_correct ; auto. + - + intros env t tg. + rewrite negate_correct ; auto. + - intros t w0. + unfold eval_tt. + intros. + rewrite make_impl_map with (eval := eval_nformula env). + eapply ZChecker_sound; eauto. + tauto. +Qed. + +Record is_diff_env_elt (fr : positive) (env env' : positive -> Z) (x:positive):= + { + eq_env : env x = env' x; + eq_diff : env x = env' (xO (fr+ x)) - env' (xI (fr + x)); + pos_xO : env' (xO (fr+x)) >= 0; + pos_xI : env' (xI (fr+x)) >= 0; + }. + + +Definition is_diff_env (s : Vars.t) (env env' : positive -> Z) := + let fr := Pos.succ (Vars.max_element s) in + forall x, Vars.mem x s = true -> + is_diff_env_elt fr env env' x. + +Definition mk_diff_env (s : Vars.t) (env : positive -> Z) := + let fr := Vars.max_element s in + fun x => + if Pos.leb x fr + then env x + else + let fr' := Pos.succ fr in + match x with + | xO x => if Z.leb (env (x - fr')%positive) 0 + then 0 else env (x -fr')%positive + | xI x => if Z.leb (env (x - fr')%positive) 0 + then - (env (x - fr')%positive) else 0 + | xH => 0 + end. + +Lemma le_xO : forall x, (x <= xO x)%positive. +Proof. + intros. + change x with (1 * x)%positive at 1. + change (xO x) with (2 * x)%positive. + apply Pos.mul_le_mono. + compute. congruence. + apply Pos.le_refl. +Qed. + +Lemma leb_xO_false : + (forall x y, x <=? y = false -> + xO x <=? y = false)%positive. +Proof. + intros. + rewrite Pos.leb_nle in *. + intro. apply H. + eapply Pos.le_trans ; eauto. + apply le_xO. +Qed. + +Lemma leb_xI_false : + (forall x y, x <=? y = false -> + xI x <=? y = false)%positive. +Proof. + intros. + rewrite Pos.leb_nle in *. + intro. apply H. + eapply Pos.le_trans ; eauto. + generalize (le_xO x). + intros. + eapply Pos.le_trans ; eauto. + change (xI x) with (Pos.succ (xO x))%positive. + apply Pos.lt_le_incl. + apply Pos.lt_succ_diag_r. +Qed. + +Lemma is_diff_env_ex : forall s env, + is_diff_env s env (mk_diff_env s env). +Proof. + intros. + unfold is_diff_env, mk_diff_env. + intros. + assert + ((Pos.succ (Vars.max_element s) + x <=? Vars.max_element s = false)%positive). + { + rewrite Pos.leb_nle. + intro. + eapply (Pos.lt_irrefl (Pos.succ (Vars.max_element s) + x)). + eapply Pos.le_lt_trans ; eauto. + generalize (Pos.lt_succ_diag_r (Vars.max_element s)). + intro. + eapply Pos.lt_trans ; eauto. + apply Pos.lt_add_r. + } + constructor. + - apply Vars.max_element_max in H. + rewrite <- Pos.leb_le in H. + rewrite H. auto. + - + rewrite leb_xO_false by auto. + rewrite leb_xI_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0); ring. + - rewrite leb_xO_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0) eqn:EQ. + apply Z.le_ge. + apply Z.le_refl. + rewrite Z.leb_gt in EQ. + apply Z.le_ge. + apply Z.lt_le_incl. + auto. + - rewrite leb_xI_false by auto. + rewrite Pos.add_comm. + rewrite Pos.add_sub. + destruct (env x <=? 0) eqn:EQ. + rewrite Z.leb_le in EQ. + apply Z.le_ge. + apply Z.opp_nonneg_nonpos; auto. + apply Z.le_ge. + apply Z.le_refl. +Qed. + +Lemma env_bounds : forall tg env s, + let fr := Pos.succ (Vars.max_element s) in + exists env', is_diff_env s env env' + /\ + eval_bf (Zeval_formula env') (bound_vars tg fr s). +Proof. + intros. + assert (DIFF:=is_diff_env_ex s env). + exists (mk_diff_env s env). split ; auto. + unfold bound_vars. + rewrite FSetPositive.PositiveSet.fold_1. + revert DIFF. + set (env' := mk_diff_env s env). + intro. + assert (ACC : eval_bf (Zeval_formula env') TT ). + { + simpl. auto. + } + revert ACC. + match goal with + | |- context[@TT ?A ?B ?C ?D] => generalize (@TT A B C D) as acc + end. + unfold is_diff_env in DIFF. + assert (DIFFL : forall x, In x (FSetPositive.PositiveSet.elements s) -> + (x < fr)%positive /\ + is_diff_env_elt fr env env' x). + { + intros. + rewrite <- Vars.mem_elements in H. + split. + apply Vars.max_element_max in H. + unfold fr in *. + eapply Pos.le_lt_trans ; eauto. + apply Pos.lt_succ_diag_r. + apply DIFF; auto. + } + clear DIFF. + match goal with + | |- context[fold_left ?F _ _] => + set (FUN := F) + end. + induction (FSetPositive.PositiveSet.elements s). + - simpl; auto. + - simpl. + intros. + eapply IHl ; eauto. + + intros. apply DIFFL. + simpl ; auto. + + unfold FUN. + simpl. + split ; auto. + assert (HYP : (a < fr /\ is_diff_env_elt fr env env' a)%positive). + { + apply DIFFL. + simpl. tauto. + } + destruct HYP as (LT & DIFF). + destruct DIFF. + rewrite <- eq_env0. + tauto. +Qed. + +Definition agree_env (v : Vars.t) (env env' : positive -> Z) : Prop := + forall x, Vars.mem x v = true -> env x = env' x. + +Lemma agree_env_subset : forall s1 s2 env env', + agree_env s1 env env' -> + Vars.is_subset s2 s1 -> + agree_env s2 env env'. +Proof. + unfold agree_env. + intros. + apply H. apply H0; auto. +Qed. + +Lemma agree_env_union : forall s1 s2 env env', + agree_env (Vars.union s1 s2) env env' -> + agree_env s1 env env' /\ agree_env s2 env env'. +Proof. + split; + eapply agree_env_subset; eauto. + apply Vars.is_subset_union_l. + apply Vars.is_subset_union_r. +Qed. + + + +Lemma agree_env_eval_expr : + forall env env' e + (AGREE : agree_env (vars_of_pexpr e) env env'), + Zeval_expr env e = Zeval_expr env' e. +Proof. + induction e; simpl;intros; + try (apply agree_env_union in AGREE; destruct AGREE); try f_equal ; auto. + - intros ; apply AGREE. + apply Vars.mem_singleton. +Qed. + +Lemma agree_env_eval_bf : + forall env env' f + (AGREE: agree_env (vars_of_bformula f) env env'), + eval_bf (Zeval_formula env') f <-> + eval_bf (Zeval_formula env) f. +Proof. + induction f; simpl; intros ; + try (apply agree_env_union in AGREE; destruct AGREE) ; try intuition fail. + - + unfold Zeval_formula. + destruct t. + simpl in * ; intros. + apply agree_env_union in AGREE ; destruct AGREE. + rewrite <- agree_env_eval_expr with (env:=env) by auto. + rewrite <- agree_env_eval_expr with (e:= Frhs) (env:=env) by auto. + tauto. +Qed. + +Lemma bound_problem_sound : forall tg f, + (forall env' : PolEnv Z, + eval_bf (Zeval_formula env') + (bound_problem tg f)) -> + forall env, + eval_bf (Zeval_formula env) f. +Proof. + intros. + unfold bound_problem in H. + destruct (env_bounds tg env (vars_of_bformula f)) + as (env' & DIFF & EVAL). + simpl in H. + apply H in EVAL. + eapply agree_env_eval_bf ; eauto. + unfold is_diff_env, agree_env in *. + intros. + apply DIFF in H0. + destruct H0. + intuition. +Qed. + + + +Definition ZTautoCheckerExt (f : BFormula (Formula Z)) (w : list ZArithProof) : bool := + ZTautoChecker (bound_problem (fun _ _ _ => tt) f) w. + +Lemma ZTautoCheckerExt_sound : forall f w, ZTautoCheckerExt f w = true -> forall env, eval_bf (Zeval_formula env) f. +Proof. + intros. + unfold ZTautoCheckerExt in H. + specialize (ZTautoChecker_sound _ _ H). + intros ; apply bound_problem_sound with (tg:= fun _ _ _ => tt); auto. Qed. Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := @@ -1028,18 +1499,10 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. -(*Lemma hyps_of_pt_correct : forall pt l, *) - - - - - - Open Scope Z_scope. (** To ease bindings from ml code **) -(*Definition varmap := Quote.varmap.*) Definition make_impl := Refl.make_impl. Definition make_conj := Refl.make_conj. @@ -1047,9 +1510,9 @@ Require VarMap. (*Definition varmap_type := VarMap.t Z. *) Definition env := PolEnv Z. -Definition node := @VarMap.Node Z. +Definition node := @VarMap.Branch Z. Definition empty := @VarMap.Empty Z. -Definition leaf := @VarMap.Leaf Z. +Definition leaf := @VarMap.Elt Z. Definition coneMember := ZWitness. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index af292c088f..3f9f4726e7 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -19,7 +19,6 @@ let debug = false -open Util open Big_int open Num open Polynomial @@ -31,6 +30,16 @@ module C2Ml = Mutils.CoqToCaml let use_simplex = ref true +type ('prf,'model) res = + | Prf of 'prf + | Model of 'model + | Unknown + +type zres = (Mc.zArithProof , (int * Mc.z list)) res + +type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res + + open Mutils type 'a number_spec = { bigint_to_number : big_int -> 'a; @@ -181,7 +190,7 @@ let build_dual_linear_system l = {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) - +open Util (** [direct_linear_prover l] does not handle strict inegalities *) let fourier_linear_prover l = @@ -201,11 +210,11 @@ let direct_linear_prover 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 + 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 @@ -253,9 +262,6 @@ let simple_linear_prover l = (* Fourier elimination should handle > *) 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) @@ -268,7 +274,7 @@ let linear_prover_cstr sys = match simple_linear_prover sysi with | None -> None - | Some cert -> Some (proof_of_farkas (env_of_list prfi) cert) + | Some cert -> Some (ProofFormat.proof_of_farkas (env_of_list prfi) cert) let linear_prover_cstr = if debug @@ -301,15 +307,14 @@ let develop_constraint z_spec (e,k) = - 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 *) + | Unsat of ProofFormat.prf_rule (* Unsatisfiable *) + | Cut of cstr * ProofFormat.prf_rule (* Cutting plane *) + | Normalise of cstr * ProofFormat.prf_rule (* Coefficients may be normalised i.e relatively prime *) -exception FoundProof of prf_rule +exception FoundProof of ProofFormat.prf_rule (** [check_sat] @@ -336,17 +341,17 @@ let check_int_sat (cstr,prf) = coeffs = Vect.div gcd coeffs; op = op ; cst = cst // gcd } in - Normalise(cstr,Gcd(gcdi,prf)) + Normalise(cstr,ProofFormat.Gcd(gcdi,prf)) (* Normalise(cstr,CutPrf prf)*) end else match op with - | Eq -> Unsat (CutPrf prf) + | Eq -> Unsat (ProofFormat.CutPrf prf) | Ge -> let cstr = { coeffs = Vect.div gcd coeffs; op = op ; cst = ceiling_num (cst // gcd) - } in Cut(cstr,CutPrf prf) + } in Cut(cstr,ProofFormat.CutPrf prf) | Gt -> failwith "check_sat : Unexpected operator" @@ -363,29 +368,6 @@ let apply_and_normalise check f psys = ) [] 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 - - match o with - | 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)) @@ -393,11 +375,11 @@ let is_linear_for v pc = -let non_linear_pivot sys pc v 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 @@ -423,7 +405,33 @@ let elim_simple_linear_equality sys0 = iterate_until_stable elim sys0 -let saturate_linear_equality_non_linear sys0 = + +let output_sys o sys = + List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys + +let subst sys = + let sys' = WithProof.subst sys in + if debug then Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + sys' + + + +(** [saturate_linear_equality sys] generate new constraints + obtained by eliminating linear equalities by pivoting. + For integers, the obtained constraints are sound but not complete. + *) + let saturate_by_linear_equalities sys0 = + WithProof.saturate_subst false sys0 + + +let saturate_by_linear_equalities sys = + let sys' = saturate_by_linear_equalities sys in + if debug then Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" output_sys sys output_sys sys' ; + sys' + + + +(* let saturate_linear_equality_non_linear sys0 = let (l,_) = extract_all (is_substitution false) sys0 in let rec elim l acc = match l with @@ -432,18 +440,51 @@ let saturate_linear_equality_non_linear sys0 = let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in elim l' (nc@acc) in elim l [] + *) +let bounded_vars (sys: WithProof.t list) = + let l = (fst (extract_all (fun ((p,o),prf) -> + LinPoly.is_variable p + ) sys)) in + List.fold_left (fun acc (i,wp) -> IMap.add i wp acc) IMap.empty l + +let rec power n p = + if n = 1 then p + else WithProof.product p (power (n-1) p) + +let bound_monomial mp m = + if Monomial.is_var m || Monomial.is_const m + then None + else + try + Some (Monomial.fold + (fun v i acc -> + let wp = IMap.find v mp in + WithProof.product (power i wp) acc) m (WithProof.const (Int 1)) + ) + with Not_found -> None + + +let bound_monomials (sys:WithProof.t list) = + let mp = bounded_vars sys in + let m = + List.fold_left (fun acc ((p,_),_) -> + Vect.fold (fun acc v _ -> let m = LinPoly.MonT.retrieve v in + match bound_monomial mp m with + | None -> acc + | Some r -> IMap.add v r acc) acc p) IMap.empty sys in + IMap.fold (fun _ e acc -> e::acc) m [] 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 + List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),ProofFormat.Hyp i)) sys let square_of_var i = let x = LinPoly.var i in - ((LinPoly.product x x,Ge),(Square x)) + ((LinPoly.product x x,Ge),(ProofFormat.Square x)) (** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. @@ -462,7 +503,7 @@ let nlinear_preprocess (sys:WithProof.t list) = 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 + ((m, Ge), (ProofFormat.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 @@ -482,16 +523,16 @@ let nlinear_preprocess (sys:WithProof.t list) = 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 sys2 = saturate_by_linear_equalities 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 + | None -> Unknown | Some cert -> - Some (cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) + Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) let linear_prover_with_cert prfdepth sys = @@ -500,9 +541,9 @@ let linear_prover_with_cert prfdepth sys = let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in match linear_prover_cstr sys with - | None -> None + | None -> Unknown | Some cert -> - Some (cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) + Prf (ProofFormat.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 *) @@ -643,7 +684,7 @@ open Polynomial -type prf_sys = (cstr * prf_rule) list +type prf_sys = (cstr * ProofFormat.prf_rule) list @@ -661,7 +702,7 @@ let pivot v (c1,p1) (c2,p2) = op = opAdd op1 op2 ; cst = n1 */ cv1 +/ n2 */ cv2 }, - AddPrf(mul_cst_proof cv1 p1,mul_cst_proof cv2 p2)) in + ProofFormat.add_proof (ProofFormat.mul_cst_proof cv1 p1) (ProofFormat.mul_cst_proof cv2 p2)) in match Vect.get v v1 , Vect.get v v2 with | Int 0 , _ | _ , Int 0 -> None @@ -747,7 +788,7 @@ let reduce_coprime psys = 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 + let prf = ProofFormat.add_proof (ProofFormat.mul_cst_proof l1' p1) (ProofFormat.mul_cst_proof l2' p2) in Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) @@ -798,7 +839,7 @@ let reduce_var_change psys = 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 + ProofFormat.add_proof (ProofFormat.mul_cst_proof m p) p') in Some (apply_and_normalise check_int_sat pivot_eq sys) @@ -871,40 +912,42 @@ let get_bound sys = let check_sys sys = List.for_all (fun (c,p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) sys +open ProofFormat let xlia (can_enum:bool) reduction_equations sys = - let rec enum_proof (id:int) (sys:prf_sys) : ProofFormat.proof option = + let rec enum_proof (id:int) (sys:prf_sys) = 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 ? *) + | None -> Unknown (* 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 + | Prf prfl -> + Prf(ProofFormat.Enum(id,ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf1),e, + ProofFormat.proof_of_farkas (env_of_list prf) (Vect.from_list prf2),prfl)) + | _ -> Unknown ) - and start_enum id e clb cub sys = + and start_enum id e clb cub sys = if clb >/ cub - then Some [] + then Prf [] 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 aux_lia (id+1) ((eq, ProofFormat.Def id) :: sys) with + | Unknown | Model _ -> Unknown + | Prf prf -> match start_enum id e (clb +/ (Int 1)) cub sys with - | None -> None - | Some l -> Some (prf::l) + | Prf l -> Prf (prf::l) + | _ -> Unknown - and aux_lia (id:int) (sys:prf_sys) : ProofFormat.proof option = + + and aux_lia (id:int) (sys:prf_sys) = assert (check_sys sys) ; if debug then Printf.printf "xlia: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; try @@ -912,11 +955,11 @@ let xlia (can_enum:bool) reduction_equations sys = 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 + | Some prf -> Prf (Step(id,prf,Done)) + | None -> if can_enum then enum_proof id sys else Unknown with FoundProof prf -> (* [reduction_equations] can find a proof *) - Some(Step(id,prf,Done)) in + Prf(Step(id,prf,Done)) in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) let id = 1 + (List.fold_left @@ -925,10 +968,10 @@ let xlia (can_enum:bool) reduction_equations sys = try let sys = simpl_sys sys in aux_lia id sys - with FoundProof pr -> Some(Step(id,pr,Done)) in + with FoundProof pr -> Prf(Step(id,pr,Done)) in match orpf with - | None -> None - | Some prf -> + | Unknown | Model _ -> Unknown + | Prf prf -> let env = CList.interval 0 (id - 1) in if debug then begin Printf.fprintf stdout "direct proof %a\n" output_proof prf; @@ -939,21 +982,25 @@ let xlia (can_enum:bool) reduction_equations sys = if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) - *) Some prf + *) Prf 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 xlia_simplex env red sys = + let compile_prf sys prf = + 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 + Prf (compile_proof 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) + try + let sys = red sys in + + match Simplex.integer_solver sys with + | None -> Unknown + | Some prf -> compile_prf sys prf + with FoundProof prf -> compile_prf sys (Step(0,prf,Done)) let xlia env0 en red sys = - if !use_simplex then xlia_simplex env0 sys + if !use_simplex then xlia_simplex env0 red sys else xlia en red sys @@ -971,9 +1018,9 @@ let gen_bench (tac, prover) can_enum prfdepth sys = Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ; begin match res with - | None -> + | Unknown | Model _ -> Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac - | Some res -> + | Prf res -> Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac end ; @@ -987,7 +1034,14 @@ let lia (can_enum:bool) (prfdepth:int) sys = if debug then begin Printf.fprintf stdout "Input problem\n"; List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + Printf.fprintf stdout "Input problem\n"; + let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" in + List.iter (fun ((p,op),_) -> Printf.fprintf stdout "(assert (%s %a))\n" (string_of_op op) Vect.pp_smt p) sys; end; + let sys = subst sys in + let bnd = bound_monomials sys in (* To deal with non-linear monomials *) + let sys = bnd@(saturate_by_linear_equalities sys)@sys in + 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' @@ -1013,7 +1067,7 @@ let nlia enum prfdepth sys = 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 sys2 = saturate_by_linear_equalities sys1 in let sys3 = nlinear_preprocess (sys1@sys2) in let sys4 = make_cstr_system ((*sys2@*)sys3) in diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index e925f1bc5e..3428428441 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -15,6 +15,15 @@ module Mc = Micromega If set, use the Simplex method, otherwise use Fourier *) val use_simplex : bool ref +type ('prf,'model) res = + | Prf of 'prf + | Model of 'model + | Unknown + +type zres = (Mc.zArithProof , (int * Mc.z list)) res + +type qres = (Mc.q Mc.psatz , (int * Mc.q list)) res + (** [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 @@ -27,16 +36,16 @@ 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 +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [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 +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [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 +val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres (** [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 nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 6c04fe9a8a..de9dec0f74 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -14,7 +14,7 @@ (* *) (* - Modules M, Mc, Env, Cache, CacheZ *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* Frédéric Besson (Irisa/Inria) 2006-2019 *) (* *) (************************************************************************) @@ -103,6 +103,7 @@ let () = *) type tag = Tag.t +module Mc = Micromega (** * An atom is of the form: @@ -111,205 +112,30 @@ type tag = Tag.t * parametrized by 'cst, which is used as the type of constants. *) -type 'cst atom = 'cst Micromega.formula +type 'cst atom = 'cst Mc.formula -(** - * Micromega's encoding of formulas. - * By order of appearance: boolean constants, variables, atoms, conjunctions, - * disjunctions, negation, implication. -*) - -type 'cst formula = - | TT - | FF - | X of EConstr.constr - | A of 'cst atom * tag * EConstr.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.Id.t option * 'cst formula +type 'cst formula = ('cst atom, EConstr.constr,tag * EConstr.constr,Names.Id.t) Mc.gFormula -(** - * Formula pretty-printer. - *) +type 'cst clause = ('cst Mc.nFormula, tag * EConstr.constr) Mc.clause +type 'cst cnf = ('cst Mc.nFormula, tag * EConstr.constr) Mc.cnf -let rec pp_formula o f = + +let rec pp_formula o (f:'cst formula) = + Mc.( match f with | TT -> output_string o "tt" | FF -> output_string o "ff" | X c -> output_string o "X " - | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t - | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 + | A(_,(t,_)) -> Printf.fprintf o "A(%a)" Tag.pp t + | Cj(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.Id.to_string id - | None -> "") pp_formula f2 + | I(f1,n,f2) -> Printf.fprintf o "I(%a,%s,%a)" + pp_formula f1 + (match n with + | Some id -> Names.Id.to_string id + | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f - - -let rec map_atoms fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X x - | A (at,tg,cstr) -> A(fct at,tg,cstr) - | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) - | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) - | N f -> N(map_atoms fct f) - | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) - -let rec map_prop fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X (fct x) - | A (at,tg,cstr) -> A(at,tg,cstr) - | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) - | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) - | N f -> N(map_prop fct f) - | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) - -(** - * Collect the identifiers of a (string of) implications. Implication labels - * are inherited from Coq/CoC's higher order dependent type constructor (Pi). - *) - -let rec ids_of_formula f = - match f with - | I(f1,Some id,f2) -> id::(ids_of_formula f2) - | _ -> [] - -(** - * A clause is a list of (tagged) nFormulas. - * nFormulas are normalized formulas, i.e., of the form: - * cPol \{=,<>,>,>=\} 0 - * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). - *) - -type 'cst clause = ('cst Micromega.nFormula * tag) list - -(** - * A CNF is a list of clauses. - *) - -type 'cst cnf = ('cst clause) list - -(** - * True and False are empty cnfs and clauses. - *) - -let tt : 'cst cnf = [] - -let ff : 'cst cnf = [ [] ] - -(** - * A refinement of cnf with tags left out. This is an intermediary form - * between the cnf tagged list representation ('cst cnf) used to solve psatz, - * and the freeform formulas ('cst formula) that is retrieved from Coq. - *) - -module Mc = Micromega - -type 'cst mc_cnf = ('cst Mc.nFormula) list list - -(** - * From a freeform formula, build a cnf. - * The parametric functions negate and normalize are theory-dependent, and - * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v - * and RingMicromega.v). - *) - -type 'a tagged_option = T of tag list | S of 'a - -let cnf - (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) - (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = - - let negate a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in - - let normalise a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in - - let and_cnf x y = x @ y in - -let rec add_term t0 = function - | [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then T [snd t0] else S (t0::[]) - | None -> S (t0::[])) - | t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then T [snd t0 ; snd t'] - else (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l) - | None -> - (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l)) in - - - let rec or_clause cl1 cl2 = - match cl1 with - | [] -> S cl2 - | t0::cl -> - (match add_term t0 cl2 with - | S cl' -> or_clause cl cl' - | T l -> T l) in - - - - let or_clause_cnf t f = - List.fold_right (fun e (acc,tg) -> - match or_clause t e with - | S cl -> (cl :: acc,tg) - | T l -> (acc,tg@l)) f ([],[]) in - - - let rec or_cnf f f' = - match f with - | [] -> tt,[] - | e :: rst -> - let (rst_f',t) = or_cnf rst f' in - let (e_f', t') = or_clause_cnf e f' in - (rst_f' @ e_f', t @ t') in - - - let rec xcnf (polarity : bool) f = - match f with - | TT -> if polarity then (tt,[]) else (ff,[]) - | FF -> if polarity then (ff,[]) else (tt,[]) - | X p -> if polarity then (ff,[]) else (ff,[]) - | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) - | N(e) -> xcnf (not polarity) e - | C(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then and_cnf e1 e2, t1 @ t2 - else let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - | D(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 - | I(e1,_,e2) -> - let e1 , t1 = (xcnf (not polarity) e1) in - let e2 , t2 = (xcnf polarity e2) in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 in - - xcnf true f + ) (** @@ -344,10 +170,11 @@ struct let mic_modules = [ ["Coq";"Lists";"List"]; - ["ZMicromega"]; - ["Tauto"]; - ["RingMicromega"]; - ["EnvRing"]; + ["Coq"; "micromega";"ZMicromega"]; + ["Coq"; "micromega";"Tauto"]; + ["Coq"; "micromega"; "DeclConstant"]; + ["Coq"; "micromega";"RingMicromega"]; + ["Coq"; "micromega";"EnvRing"]; ["Coq"; "micromega"; "ZMicromega"]; ["Coq"; "micromega"; "RMicromega"]; ["Coq" ; "micromega" ; "Tauto"]; @@ -380,7 +207,7 @@ struct * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) + let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules [@@@ocaml.warning "+3"] @@ -405,6 +232,15 @@ struct let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") + let coq_nat = lazy (init_constant "nat") + let coq_unit = lazy (init_constant "unit") + (* let coq_option = lazy (init_constant "option")*) + let coq_None = lazy (init_constant "None") + let coq_tt = lazy (init_constant "tt") + let coq_Inl = lazy (init_constant "inl") + let coq_Inr = lazy (init_constant "inr") + + let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") @@ -431,6 +267,7 @@ struct let coq_CPlus = lazy (m_constant "CPlus") let coq_CMinus = lazy (m_constant "CMinus") let coq_CMult = lazy (m_constant "CMult") + let coq_CPow = lazy (m_constant "CPow") let coq_CInv = lazy (m_constant "CInv") let coq_COpp = lazy (m_constant "COpp") @@ -477,6 +314,7 @@ struct let coq_Rmult = lazy (r_constant "Rmult") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") + let coq_powerZR = lazy (r_constant "powerRZ") let coq_IZR = lazy (r_constant "IZR") let coq_IQR = lazy (r_constant "Q2R") @@ -508,6 +346,8 @@ struct let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") + let coq_GT = lazy (m_constant "GT") + let coq_TT = lazy (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") @@ -615,6 +455,22 @@ struct | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) + (** [is_ground_term env sigma term] holds if the term [term] + is an instance of the typeclass [DeclConstant.GT term] + i.e. built from user-defined constants and functions. + NB: This mechanism is used to customise the reification process to decide + what to consider as a constant (see [parse_constant]) + *) + + let is_ground_term env sigma term = + let typ = Retyping.get_type_of env sigma term in + try + ignore (Typeclasses.resolve_one_typeclass env sigma (EConstr.mkApp(Lazy.force coq_GT,[| typ;term|]))) ; + true + with + | Not_found -> false + + let parse_z sigma term = let (i,c) = get_left_construct sigma term in match i with @@ -652,6 +508,7 @@ struct | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y + | Mc.CPow(x,y) -> Printf.fprintf o "(%a ^ _)" pp_Rcst x | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t @@ -665,6 +522,11 @@ struct | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) + | Mc.CPow(x,y) -> EConstr.mkApp(Lazy.force coq_CPow, [| dump_Rcst x ; + match y with + | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_Inl,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_z z|]) + | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Inr,[| Lazy.force coq_Z ; Lazy.force coq_nat; dump_nat n|]) + |]) | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) @@ -718,9 +580,18 @@ struct | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in pp_pol o e - let pp_cnf pp_c o f = - let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in - List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f +(* let pp_clause pp_c o (f: 'cst clause) = + List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) f *) + + let pp_clause_tag o (f: 'cst clause) = + List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f + +(* let pp_cnf pp_c o (f:'cst cnf) = + List.iter (fun l -> Printf.fprintf o "[%a]" (pp_clause pp_c) l) f *) + + let pp_cnf_tag o (f:'cst cnf) = + List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause_tag l) f + let dump_psatz typ dump_z e = let z = Lazy.force typ in @@ -842,34 +713,74 @@ struct module Env = struct - let compute_rank_add env sigma v = - let rec _add env n v = - match env with - | [] -> ([v],n) - | e::l -> - if EConstr.eq_constr_nounivs sigma e v - then (env,n) - else - let (env,n) = _add l ( n+1) v in - (e::env,n) in - let (env, n) = _add env 1 v in - (env, CamlToCoq.positive n) - let get_rank env sigma v = + type t = { + vars : EConstr.t list ; + (* The list represents a mapping from EConstr.t to indexes. *) + gl : gl; + (* The evar_map may be updated due to unification of universes *) + } + + let empty gl = + { + vars = []; + gl = gl + } + + + (** [eq_constr gl x y] returns an updated [gl] if x and y can be unified *) + let eq_constr gl x y = + let evd = gl.sigma in + match EConstr.eq_constr_universes gl.env evd x y with + | Some csts -> + let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in + begin + match Evd.add_constraints evd csts with + | evd -> Some {gl with sigma = evd} + | exception Univ.UniverseInconsistency _ -> None + end + | None -> None + + let compute_rank_add env v = + let rec _add gl vars n v = + match vars with + | [] -> (gl, [v] ,n) + | e::l -> + match eq_constr gl e v with + | Some gl' -> (gl', vars , n) + | None -> + let (gl,l',n) = _add gl l ( n+1) v in + (gl,e::l',n) in + let (gl',vars', n) = _add env.gl env.vars 1 v in + ({vars=vars';gl=gl'}, CamlToCoq.positive n) + + let get_rank env v = + let evd = env.gl.sigma in let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> - if EConstr.eq_constr sigma e v + if EConstr.eq_constr evd e v then n else _get_rank l (n+1) in - _get_rank env 1 + _get_rank env.vars 1 - - let empty = [] + let elements env = env.vars - let elements env = env +(* let string_of_env gl env = + let rec string_of_env i env acc = + match env with + | [] -> acc + | e::env -> string_of_env (i+1) env + (IMap.add i + (Pp.string_of_ppcmds + (Printer.pr_econstr_env gl.env gl.sigma e)) acc) in + string_of_env 1 env IMap.empty + *) + let pp gl env = + let ppl = List.mapi (fun i e -> Pp.str "x" ++ Pp.int (i+1) ++ Pp.str ":" ++ Printer.pr_econstr_env gl.env gl.sigma e)env in + List.fold_right (fun e p -> e ++ Pp.str " ; " ++ p ) ppl (Pp.str "\n") end (* MODULE END: Env *) @@ -877,20 +788,13 @@ struct * This is the big generic function for expression parsers. *) - let parse_expr env sigma parse_constant parse_exp ops_spec term_env term = + let parse_expr gl parse_constant parse_exp ops_spec env term = if debug - then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term); + then ( + Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env gl.env gl.sigma term)); -(* - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in -*) let parse_variable env term = - let (env,n) = Env.compute_rank_add env sigma term in + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in let rec parse_expr env term = @@ -899,36 +803,36 @@ struct let (expr2,env) = parse_expr env t2 in (op expr1 expr2,env) in - try (Mc.PEc (parse_constant term) , env) + try (Mc.PEc (parse_constant gl term) , env) with ParseError -> - match EConstr.kind sigma term with + match EConstr.kind gl.sigma term with | App(t,args) -> ( - match EConstr.kind sigma t with + match EConstr.kind gl.sigma t with | Const c -> - ( match assoc_ops sigma t ops_spec with + ( match assoc_ops gl.sigma t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin + | Opp -> let (expr,env) = parse_expr env args.(0) in + (Mc.PEopp expr, env) + | Power -> + begin try let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in - (power , env) + (power , env) with e when CErrors.noncritical e -> (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - ) + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + end + | Ukn s -> + if debug + then (Printf.printf "unknown op: %s\n" s; flush stdout;); + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + ) | _ -> parse_variable env term ) | _ -> parse_variable env term in - parse_expr term_env term + parse_expr env term let zop_spec = [ @@ -954,9 +858,23 @@ struct coq_Ropp , Opp ; coq_Rpower , Power] - let zconstant = parse_z - let qconstant = parse_q + (** [parse_constant parse gl t] returns the reification of term [t]. + If [t] is a ground term, then it is first reduced to normal form + before using a 'syntactic' parser *) + let parse_constant parse gl t = + if is_ground_term gl.env gl.sigma t + then + parse gl.sigma (Redexpr.cbv_vm gl.env gl.sigma t) + else raise ParseError + + let zconstant = parse_constant parse_z + let qconstant = parse_constant parse_q + let nconstant = parse_constant parse_nat + (* NB: R is a different story. + Because it is axiomatised, reducing would not be effective. + Therefore, there is a specific parser for constant over R + *) let rconst_assoc = [ @@ -966,60 +884,69 @@ struct (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] - let rec rconstant sigma term = - match EConstr.kind sigma term with - | Const x -> - if EConstr.eq_constr sigma term (Lazy.force coq_R0) - then Mc.C0 + let rconstant gl term = + + let sigma = gl.sigma in + + let rec rconstant term = + match EConstr.kind sigma term with + | Const x -> + if EConstr.eq_constr sigma term (Lazy.force coq_R0) + then Mc.C0 else if EConstr.eq_constr sigma term (Lazy.force coq_R1) - then Mc.C1 - else raise ParseError - | App(op,args) -> - begin - try - (* the evaluation order is important in the following *) - let f = assoc_const sigma op rconst_assoc in - let a = rconstant sigma args.(0) in - let b = rconstant sigma args.(1) in - f a b - with + then Mc.C1 + else raise ParseError + | App(op,args) -> + begin + try + (* the evaluation order is important in the following *) + let f = assoc_const sigma op rconst_assoc in + let a = rconstant args.(0) in + let b = rconstant args.(1) in + f a b + with ParseError -> match op with | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> - let arg = rconstant sigma args.(0) in + let arg = rconstant args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> + Mc.CPow(rconstant args.(0) , Mc.Inr (nconstant gl args.(1))) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> + Mc.CQ (qconstant gl args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> + Mc.CZ (zconstant gl args.(0)) | _ -> raise ParseError end + | _ -> raise ParseError in - | _ -> raise ParseError + rconstant term - let rconstant env sigma term = + let rconstant gl term = if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); - let res = rconstant sigma term in + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env gl.env gl.sigma term ++ fnl ()); + let res = rconstant gl term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res - let parse_zexpr env sigma = parse_expr env sigma - (zconstant sigma) + let parse_zexpr gl = parse_expr gl + zconstant (fun expr x -> - let exp = (parse_z sigma x) in + let exp = (zconstant gl x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec - let parse_qexpr env sigma = parse_expr env sigma - (qconstant sigma) + let parse_qexpr gl = parse_expr gl + qconstant (fun expr x -> - let exp = parse_z sigma x in + let exp = zconstant gl x in match exp with | Mc.Zneg _ -> begin @@ -1031,24 +958,23 @@ struct Mc.PEpow(expr,exp)) qop_spec - let parse_rexpr env sigma = parse_expr env sigma - (rconstant env sigma) + let parse_rexpr gl = parse_expr gl + rconstant (fun expr x -> - let exp = Mc.N.of_nat (parse_nat sigma x) in + let exp = Mc.N.of_nat (parse_nat gl.sigma x) in Mc.PEpow(expr,exp)) rop_spec - let parse_arith parse_op parse_expr term_env cstr gl = + let parse_arith parse_op parse_expr env cstr gl = let sigma = gl.sigma in - let env = gl.env in if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env env sigma cstr ++ fnl ()); + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); match EConstr.kind sigma cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,term_env) = parse_expr env sigma term_env lhs in - let (e2,term_env) = parse_expr env sigma term_env rhs in - ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},term_env) + let (e1,env) = parse_expr gl env lhs in + let (e2,env) = parse_expr gl env rhs in + ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" let parse_zarith = parse_arith parse_zop parse_zexpr @@ -1059,14 +985,14 @@ struct (* generic parsing of arithmetic expressions *) - let mkC f1 f2 = C(f1,f2) - let mkD f1 f2 = D(f1,f2) - let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) - let mkI f1 f2 = I(f1,None,f2) + let mkC f1 f2 = Mc.Cj(f1,f2) + let mkD f1 f2 = Mc.D(f1,f2) + let mkIff f1 f2 = Mc.Cj(Mc.I(f1,None,f2),Mc.I(f2,None,f1)) + let mkI f1 f2 = Mc.I(f1,None,f2) let mkformula_binary g term f1 f2 = match f1 , f2 with - | X _ , X _ -> X(term) + | Mc.X _ , Mc.X _ -> Mc.X(term) | _ -> g f1 f2 (** @@ -1079,8 +1005,8 @@ struct let parse_atom env tg t = try let (at,env) = parse_atom env t gl in - (A(at,tg,t), env,Tag.next tg) - with e when CErrors.noncritical e -> (X(t),env,tg) in + (Mc.A(at,(tg,t)), env,Tag.next tg) + with e when CErrors.noncritical e -> (Mc.X(t),env,tg) in let is_prop term = let sort = Retyping.get_sort_of gl.env gl.sigma term in @@ -1099,7 +1025,7 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg | [|a|] when EConstr.eq_constr sigma l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) + let (f,env,tg) = xparse_formula env tg a in (Mc.N(f), env,tg) | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in @@ -1109,36 +1035,41 @@ struct let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) - | _ when is_prop term -> X(term),env,tg + | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (Mc.TT,env,tg) + | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> Mc.(FF,env,tg) + | _ when is_prop term -> Mc.X(term),env,tg | _ -> raise ParseError in xparse_formula env tg ((*Reductionops.whd_zeta*) term) let dump_formula typ dump_atom f = - let rec xdump f = + let app_ctor c args = + EConstr.mkApp(Lazy.force c, Array.of_list (typ::EConstr.mkProp::Lazy.force coq_unit :: Lazy.force coq_unit :: args)) in + + let rec xdump f = match f with - | TT -> EConstr.mkApp(Lazy.force coq_TT,[|typ|]) - | FF -> EConstr.mkApp(Lazy.force coq_FF,[|typ|]) - | C(x,y) -> EConstr.mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) - | I(x,_,y) -> EConstr.mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) - | N(x) -> EConstr.mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) - | A(x,_,_) -> EConstr.mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) - | X(t) -> EConstr.mkApp(Lazy.force coq_X,[|typ ; t|]) in + | Mc.TT -> app_ctor coq_TT [] + | Mc.FF -> app_ctor coq_FF [] + | Mc.Cj(x,y) -> app_ctor coq_And [xdump x ; xdump y] + | Mc.D(x,y) -> app_ctor coq_Or [xdump x ; xdump y] + | Mc.I(x,_,y) -> app_ctor coq_Impl [xdump x ; EConstr.mkApp(Lazy.force coq_None,[|Lazy.force coq_unit|]); xdump y] + | Mc.N(x) -> app_ctor coq_Neg [xdump x] + | Mc.A(x,_) -> app_ctor coq_Atom [dump_atom x;Lazy.force coq_tt] + | Mc.X(t) -> app_ctor coq_X [t] in xdump f - let prop_env_of_formula sigma form = + let prop_env_of_formula gl form = + Mc.( let rec doit env = function - | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env sigma t) - | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> + | TT | FF | A(_,_) -> env + | X t -> fst (Env.compute_rank_add env t) + | Cj(f1,f2) | D(f1,f2) | I(f1,_,f2) -> doit (doit env f1) f2 - | N f -> doit env f in + | N f -> doit env f + in - doit [] form + doit (Env.empty gl) form) let var_env_of_formula form = @@ -1152,14 +1083,14 @@ struct let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in - + Mc.( let rec doit = function - | TT | FF | X _ -> ISet.empty - | A (a,t,c) -> vars_of_atom a - | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) + | TT | FF | X _ -> ISet.empty + | A (a,(t,c)) -> vars_of_atom a + | Cj(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) | N f -> doit f in - doit form + doit form) @@ -1212,6 +1143,12 @@ let rec dump_Rcst_as_R cst = | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CPow(x,y) -> + begin + match y with + | Mc.Inl z -> EConstr.mkApp(Lazy.force coq_powerZR,[| dump_Rcst_as_R x ; dump_z z|]) + | Mc.Inr n -> EConstr.mkApp(Lazy.force coq_Rpower,[| dump_Rcst_as_R x ; dump_nat n|]) + end | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) @@ -1247,17 +1184,17 @@ let prodn n env b = in prodrec (n,env,b) -let make_goal_of_formula sigma dexpr form = +let make_goal_of_formula gl dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - let props = prop_env_of_formula sigma form in + let props = prop_env_of_formula gl form in let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) props in + let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) (Env.elements props) in let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in @@ -1288,14 +1225,14 @@ let make_goal_of_formula sigma dexpr form = let rec xdump pi xi f = match f with - | TT -> Lazy.force coq_True - | FF -> Lazy.force coq_False - | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) - | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props sigma t in + | Mc.TT -> Lazy.force coq_True + | Mc.FF -> Lazy.force coq_False + | Mc.Cj(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) + | Mc.D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) + | Mc.I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) + | Mc.N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) + | Mc.A(x,_) -> dump_cstr xi x + | Mc.X(t) -> let idx = Env.get_rank props t in EConstr.mkRel (pi+idx) in let nb_vars = List.length vars_n in @@ -1304,10 +1241,10 @@ let make_goal_of_formula sigma dexpr form = (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) let subst_prop p = - let idx = Env.get_rank props sigma p in + let idx = Env.get_rank props p in EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in - let form' = map_prop subst_prop form in + let form' = Mc.mapX subst_prop form in (prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n) (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) @@ -1336,12 +1273,12 @@ end (** open M -let coq_Node = +let coq_Branch = lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Branch") +let coq_Elt = lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Elt") let coq_Empty = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") @@ -1354,9 +1291,9 @@ let coq_VarMap = let rec dump_varmap typ m = match m with | Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[| typ |]) - | Mc.Leaf v -> EConstr.mkApp(Lazy.force coq_Leaf,[| typ; v|]) - | Mc.Node(l,o,r) -> - EConstr.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) + | Mc.Elt v -> EConstr.mkApp(Lazy.force coq_Elt,[| typ; v|]) + | Mc.Branch(l,o,r) -> + EConstr.mkApp (Lazy.force coq_Branch, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) let vm_of_list env = @@ -1426,7 +1363,9 @@ let rec parse_hyps gl parse_arith env tg hyps = (*exception ParseError*) -let parse_goal gl parse_arith env hyps term = + + +let parse_goal gl parse_arith (env:Env.t) hyps term = (* try*) let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in @@ -1460,6 +1399,40 @@ let qq_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } +let max_tag f = 1 + (Tag.to_int (Mc.foldA (fun t1 (t2,_) -> Tag.max t1 t2) f (Tag.from 0))) + + +(** For completeness of the cutting-plane procedure, + each variable 'x' is replaced by 'y' - 'z' where + 'y' and 'z' are positive *) +let pre_processZ mt f = + + let x0 i = 2 * i in + let x1 i = 2 * i + 1 in + + let tag_of_var fr p b = + + let ip = CoqToCaml.positive fr + (CoqToCaml.positive p) in + + match b with + | None -> + let y = Mc.XO (Mc.Coq_Pos.add fr p) in + let z = Mc.XI (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x0 (x0 ip)) in + let constr = Mc.mk_eq_pos p y z in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) + | Some false -> + let y = Mc.XO (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x0 (x1 ip)) in + let constr = Mc.bound_var (Mc.XO y) in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) + | Some true -> + let z = Mc.XI (Mc.Coq_Pos.add fr p) in + let tag = Tag.from (- x1 (x1 ip)) in + let constr = Mc.bound_var (Mc.XI z) in + (tag, dump_cstr (Lazy.force coq_Z) dump_z constr) in + + Mc.bound_problem_fr tag_of_var mt f (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if @@ -1495,10 +1468,12 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* * The datastructures that aggregate prover attributes. *) -type ('option,'a,'prf) prover = { +open Certificate + +type ('option,'a,'prf,'model) prover = { name : string ; (* name of the prover *) - get_option : unit ->'option ; (* find the options of the prover *) - prover : 'option * 'a list -> 'prf option ; (* the prover itself *) + get_option : unit ->'option ; (* find the options of the prover *) + prover : ('option * 'a list) -> ('prf, 'model) Certificate.res ; (* the prover itself *) hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) @@ -1508,37 +1483,37 @@ type ('option,'a,'prf) prover = { (** - * Given a list of provers and a disjunction of atoms, find a proof of any of + * Given a prover and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover * datastructure. *) -let find_witness provers polys1 = - let provers = List.map (fun p -> - (fun l -> - match p.prover (p.get_option (),l) with - | None -> None - | Some prf -> Some(prf,p)) , p.name) provers in - try_any provers (List.map fst polys1) +let find_witness p polys1 = + let polys1 = List.map fst polys1 in + match p.prover (p.get_option (), polys1) with + | Model m -> Model m + | Unknown -> Unknown + | Prf prf -> Prf(prf,p) (** - * Given a list of provers and a CNF, find a proof for each of the clauses. + * Given a prover and a CNF, find a proof for each of the clauses. * Return the proofs as a list. *) -let witness_list prover l = +let witness_list prover l = let rec xwitness_list l = match l with - | [] -> Some [] + | [] -> Prf [] | e :: l -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w :: l) - ) in - xwitness_list l + match xwitness_list l with + | Model (m,e) -> Model (m,e) + | Unknown -> Unknown + | Prf l -> + match find_witness prover e with + | Model m -> Model (m,e) + | Unknown -> Unknown + | Prf w -> Prf (w::l) in + xwitness_list l let witness_list_tags = witness_list @@ -1546,6 +1521,7 @@ let witness_list_tags = witness_list * Prune the proof object, according to the 'diff' between two cnf formulas. *) + let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = @@ -1564,9 +1540,9 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let res = try prover.compact prf remap with x when CErrors.noncritical x -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) - match prover.prover (prover.get_option () ,List.map fst new_cl) with - | None -> failwith "proof compaction error" - | Some p -> p + match prover.prover (prover.get_option (), List.map fst new_cl) with + | Unknown | Model _ -> failwith "proof compaction error" + | Prf p -> p in if debug then begin @@ -1581,11 +1557,31 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let hyps = selecti hyps_idx old_cl in is_sublist Pervasives.(=) hyps new_cl in + + let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) + if debug then + begin + Printf.printf "CNFRES\n"; flush stdout; + List.iter (fun (cl,(prf,prover)) -> + let hyps_idx = prover.hyps prf in + let hyps = selecti hyps_idx cl in + Printf.printf "\nProver %a -> %a\n" + pp_clause_tag cl pp_clause_tag hyps;flush stdout) cnf_res; + Printf.printf "CNFNEW %a\n" pp_cnf_tag cnf_ff'; + + end; List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' + let (o,p) = + try + List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res + with Not_found -> + begin + Printf.printf "ERROR: no compatible proof" ; flush stdout; + failwith "Cannot find compatible proof" end + in + compact_proof o p x) cnf_ff' (** @@ -1594,14 +1590,15 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = *) let abstract_formula hyps f = + Mc.( let rec xabs f = match f with | X c -> X c - | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> + | A(a,(t,term)) -> if TagSet.mem t hyps then A(a,(t,term)) else X(term) + | Cj(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> C(f1,f2) ) + | f1 , f2 -> Cj(f1,f2) ) | D(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) @@ -1618,21 +1615,22 @@ let abstract_formula hyps f = ) | FF -> FF | TT -> TT - in xabs f + in xabs f) (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) let rec abstract_wrt_formula f1 f2 = + Mc.( match f1 , f2 with | X c , _ -> X c | A _ , A _ -> f2 - | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') + | Cj(a,b) , Cj(a',b') -> Cj(abstract_wrt_formula a a', abstract_wrt_formula b b') | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') | FF , FF -> FF | TT , TT -> TT | N x , N y -> N(abstract_wrt_formula x y) - | _ -> failwith "abstract_wrt_formula" + | _ -> failwith "abstract_wrt_formula") (** * This exception is raised by really_call_csdpcert if Coq's configure didn't @@ -1651,52 +1649,46 @@ let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with - X _ -> (cc,ids) - | _ -> (I(f,Some id,cc), id::ids)) + Mc.X _ -> (cc,ids) + | _ -> (Mc.I(f,Some id,cc), id::ids)) hyps (concl,[]) -let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = +let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = (* Express the goal as one big implication *) let (ff,ids) = formula_hyps_concl polys1 polys2 in + let mt = CamlToCoq.positive (max_tag ff) in - (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) - let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in - - if debug then - begin - Feedback.msg_notice (Pp.str "Formula....\n") ; - let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in - let ff = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff - end; + (* Construction of cnf *) + let pre_ff = (pre_process mt ff) in + let (cnf_ff,cnf_ff_tags) = cnf pre_ff in match witness_list_tags prover cnf_ff with - | None -> None - | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> - let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in - if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; - (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - - if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; + | Model m -> Model m + | Unknown -> Unknown + | Prf res -> (*Printf.printf "\nList %i" (List.length `res); *) + let hyps = List.fold_left + (fun s (cl,(prf,p)) -> + let tags = ISet.fold (fun i s -> + let t = fst (snd (List.nth cl i)) in + if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; + (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in + TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty (List.map fst cnf_ff_tags)) (List.combine cnf_ff res) in let ff' = abstract_formula hyps ff in - let cnf_ff',_ = cnf negate normalise unsat deduce ff' in + + let pre_ff' = pre_process mt ff' in + let cnf_ff',_ = cnf pre_ff' in + if debug then begin - Feedback.msg_notice (Pp.str "\nAFormula\n") ; - let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' + output_string stdout "\n"; + Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; + Printf.printf "TFormAbs : %a\n" pp_formula ff' ; flush stdout; + Printf.printf "TFormPre : %a\n" pp_formula pre_ff ; flush stdout; + Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff' ; flush stdout; end; (* Even if it does not work, this does not mean it is not provable @@ -1710,10 +1702,18 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 end ; *) let res' = compact_proofs cnf_ff res cnf_ff' in - let (ff',res',ids) = (ff',res', ids_of_formula ff') in + let (ff',res',ids) = (ff',res', Mc.ids_of_formula ff') in let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - Some (ids,ff',res') + Prf (ids,ff',res') + +let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = + try micromega_tauto pre_process cnf spec prover env polys1 polys2 gl + with Not_found -> + begin + Printexc.print_backtrace stdout; flush stdout; + Unknown + end (** @@ -1725,9 +1725,8 @@ let fresh_id avoid id gl = let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce + pre_process + cnf spec dumpexpr prover tac = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1735,15 +1734,19 @@ let micromega_gen let hyps = Tacmach.New.pf_hyps_types gl in try let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in + let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let dumpexpr = Lazy.force dumpexpr in + + + if debug then Feedback.msg_debug (Pp.str "Env " ++ (Env.pp gl0 env)) ; - match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in + match micromega_tauto pre_process cnf spec prover env hyps concl gl0 with + | Unknown -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Model(m,e) -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids,ff',res') -> + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 dumpexpr ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -1756,7 +1759,7 @@ let micromega_gen micromega_order_change spec res' (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula sigma ff') in + let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -1786,16 +1789,10 @@ let micromega_gen ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - -let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec prover = - (micromega_gen parse_arith negate normalise unsat deduce spec prover) - - + | x -> begin if debug then Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ())) + else raise x + end + end let micromega_order_changer cert env ff = (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) @@ -1826,10 +1823,6 @@ let micromega_order_changer cert env ff = let micromega_genr prover tac = let parse_arith = parse_rarith in - let negate = Mc.rnegate in - let normalise = Mc.rnormalise in - let unsat = Mc.runsat in - let deduce = Mc.rdeduce in let spec = lazy { typ = Lazy.force coq_R; coeff = Lazy.force coq_Rcst; @@ -1844,21 +1837,21 @@ let micromega_genr prover tac = try let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in + let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in - let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in + let hyps' = List.map (fun (n,f) -> (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in + let concl' = Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl in - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> + match micromega_tauto (fun _ x -> x) Mc.cnfQ spec prover env hyps' concl' gl0 with + | Unknown | Model _ -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Prf (ids,ff',res') -> let (ff,ids) = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in let ff' = abstract_wrt_formula ff' ff in - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -1870,7 +1863,7 @@ let micromega_genr prover tac = let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula sigma ff') in + let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -1911,8 +1904,8 @@ let micromega_genr prover = (micromega_genr prover) let lift_ratproof prover l = match prover l with - | None -> None - | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) + | Unknown | Model _ -> Unknown + | Prf c -> Prf (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list @@ -1983,22 +1976,22 @@ let rec z_to_q_pol e = let call_csdpcert_q provername poly = match call_csdpcert provername poly with - | None -> None + | None -> Unknown | Some cert -> let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate") ;None) + then Prf cert + else ((print_string "buggy certificate") ;Unknown) let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in match call_csdpcert provername l with - | None -> None + | None -> Unknown | Some cert -> let cert = Certificate.z_cert_of_pos cert in if Mc.zWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) + then Prf cert + else ((print_string "buggy certificate" ; flush stdout) ;Unknown) let xhyps_of_cone base acc prf = let rec xtract e acc = @@ -2041,12 +2034,6 @@ let hyps_of_pt pt = xhyps 0 pt ISet.empty -let hyps_of_pt pt = - let res = hyps_of_pt pt in - if debug - then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); - res - let compact_pt pt f = let translate ofset x = if x < ofset then x @@ -2141,8 +2128,8 @@ let non_linear_prover_R str o = { let non_linear_prover_Z str o = { name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); + get_option = (fun () -> (str,o)); + prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; @@ -2175,52 +2162,65 @@ let nlinear_Z = { *) let lra_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ linear_prover_Q ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + linear_prover_Q let psatz_Q i = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "real_nonlinear_prover" (Some i) ) let lra_R = - micromega_genr [ linear_prover_R ] + micromega_genr linear_prover_R let psatz_R i = - micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] + micromega_genr (non_linear_prover_R "real_nonlinear_prover" (Some i)) let psatz_Z i = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "real_nonlinear_prover" (Some i) ) let sos_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "pure_sos" None ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + (non_linear_prover_Z "pure_sos" None) let sos_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "pure_sos" None ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + (non_linear_prover_Q "pure_sos" None) let sos_R = - micromega_genr [ non_linear_prover_R "pure_sos" None ] + micromega_genr (non_linear_prover_R "pure_sos" None) -let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ linear_Z ] +let xlia = + micromega_gen parse_zarith pre_processZ Mc.cnfZ zz_domain_spec dump_zexpr + linear_Z + let xnlia = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ nlinear_Z ] + micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr + nlinear_Z let nra = - micromega_genr [ nlinear_prover_R ] + micromega_genr nlinear_prover_R let nqa = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ nlinear_prover_R ] + micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr + nlinear_prover_R + +(** Let expose [is_ground_tac] *) + +let is_ground_tac t = + Proofview.Goal.enter begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + if is_ground_term env sigma t + then Tacticals.New.tclIDTAC + else Tacticals.New.tclFAIL 0 (Pp.str "Not ground") + end + - (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index d1776b8ca4..075594cffc 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +val is_ground_tac : EConstr.constr -> unit Proofview.tactic val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index 21f0414e9c..6bf5f76a04 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -30,6 +30,9 @@ TACTIC EXTEND RED | [ "myred" ] -> { Tactics.red_in_concl } END +TACTIC EXTEND ISGROUND +| [ "is_ground" constr(t) ] -> { Coq_micromega.is_ground_tac t } +END TACTIC EXTEND PsatzZ diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index f67f1da146..b34c3b2b7d 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1,4 +1,9 @@ +type __ = Obj.t + +type unit0 = +| Tt + (** val negb : bool -> bool **) let negb = function @@ -9,6 +14,20 @@ type nat = | O | S of nat +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +(** val fst : ('a1 * 'a2) -> 'a1 **) + +let fst = function +| x,_ -> x + +(** val snd : ('a1 * 'a2) -> 'a2 **) + +let snd = function +| _,y -> y + (** val app : 'a1 list -> 'a1 list -> 'a1 list **) let rec app l m = @@ -37,6 +56,29 @@ module Coq__1 = struct end include Coq__1 +(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) + +let rec nth n0 l default = + match n0 with + | O -> (match l with + | [] -> default + | x::_ -> x) + | S m -> (match l with + | [] -> default + | _::t0 -> nth m t0 default) + +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) + +let rec map f = function +| [] -> [] +| a::t0 -> (f a)::(map f t0) + +(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) + +let rec fold_right f a0 = function +| [] -> a0 +| b::t0 -> f b (fold_right f a0 t0) + type positive = | XI of positive | XO of positive @@ -269,29 +311,6 @@ let rec pow_pos rmul x = function | XO i0 -> let p = pow_pos rmul x i0 in rmul p p | XH -> x -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - -let rec nth n0 l default = - match n0 with - | O -> (match l with - | [] -> default - | x::_ -> x) - | S m -> (match l with - | [] -> default - | _::t0 -> nth m t0 default) - -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - -let rec map f = function -| [] -> [] -| a::t0 -> (f a)::(map f t0) - -(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) - -let rec fold_right f a0 = function -| [] -> a0 -| b::t0 -> f b (fold_right f a0 t0) - module Z = struct (** val double : z -> z **) @@ -435,6 +454,12 @@ module Z = | Zpos p -> Npos p | _ -> N0 + (** val of_nat : nat -> z **) + + let of_nat = function + | O -> Z0 + | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) + (** val pos_div_eucl : positive -> z -> z * z **) let rec pos_div_eucl a b = @@ -889,53 +914,105 @@ let rec norm_aux cO cI cadd cmul csub copp ceqb = function ppow_N cO cI cadd cmul ceqb (fun p -> p) (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 -type 'a bFormula = +type ('tA, 'tX, 'aA, 'aF) gFormula = | TT | FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula - -(** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **) +| X of 'tX +| A of 'tA * 'aA +| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| N of ('tA, 'tX, 'aA, 'aF) gFormula +| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option + * ('tA, 'tX, 'aA, 'aF) gFormula + +(** val mapX : + ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) + gFormula **) + +let rec mapX f = function +| X x -> X (f x) +| Cj (f1, f2) -> Cj ((mapX f f1), (mapX f f2)) +| D (f1, f2) -> D ((mapX f f1), (mapX f f2)) +| N f1 -> N (mapX f f1) +| I (f1, o, f2) -> I ((mapX f f1), o, (mapX f f2)) +| x -> x + +(** val foldA : + ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 **) + +let rec foldA f f0 acc = + match f0 with + | A (_, an) -> f acc an + | Cj (f1, f2) -> foldA f f1 (foldA f f2 acc) + | D (f1, f2) -> foldA f f1 (foldA f f2 acc) + | N f1 -> foldA f f1 acc + | I (f1, _, f2) -> foldA f f1 (foldA f f2 acc) + | _ -> acc + +(** val cons_id : 'a1 option -> 'a1 list -> 'a1 list **) + +let cons_id id l = + match id with + | Some id0 -> id0::l + | None -> l + +(** val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list **) + +let rec ids_of_formula = function +| I (_, id, f') -> cons_id id (ids_of_formula f') +| _ -> [] + +(** val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list **) + +let rec collect_annot = function +| A (_, a) -> a::[] +| Cj (f1, f2) -> app (collect_annot f1) (collect_annot f2) +| D (f1, f2) -> app (collect_annot f1) (collect_annot f2) +| N f0 -> collect_annot f0 +| I (f1, _, f2) -> app (collect_annot f1) (collect_annot f2) +| _ -> [] + +type 'a bFormula = ('a, __, unit0, unit0) gFormula + +(** val map_bformula : + ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) + gFormula **) let rec map_bformula fct = function | TT -> TT | FF -> FF -| X -> X -| A a -> A (fct a) +| X p -> X p +| A (a, t0) -> A ((fct a), t0) | Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2)) | D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2)) | N f0 -> N (map_bformula fct f0) -| I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) +| I (f1, a, f2) -> I ((map_bformula fct f1), a, (map_bformula fct f2)) -type 'x clause = 'x list +type ('x, 'annot) clause = ('x * 'annot) list -type 'x cnf = 'x clause list +type ('x, 'annot) cnf = ('x, 'annot) clause list -(** val tt : 'a1 cnf **) +(** val cnf_tt : ('a1, 'a2) cnf **) -let tt = +let cnf_tt = [] -(** val ff : 'a1 cnf **) +(** val cnf_ff : ('a1, 'a2) cnf **) -let ff = +let cnf_ff = []::[] (** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) + clause -> ('a1, 'a2) clause option **) let rec add_term unsat deduce t0 = function | [] -> - (match deduce t0 t0 with + (match deduce (fst t0) (fst t0) with | Some u -> if unsat u then None else Some (t0::[]) | None -> Some (t0::[])) | t'::cl0 -> - (match deduce t0 t' with + (match deduce (fst t0) (fst t') with | Some u -> if unsat u then None @@ -948,8 +1025,8 @@ let rec add_term unsat deduce t0 = function | None -> None)) (** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause - -> 'a1 clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) clause -> ('a1, 'a2) clause option **) let rec or_clause unsat deduce cl1 cl2 = match cl1 with @@ -960,8 +1037,8 @@ let rec or_clause unsat deduce cl1 cl2 = | None -> None) (** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> - 'a1 cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) let or_clause_cnf unsat deduce t0 f = fold_right (fun e acc -> @@ -970,29 +1047,32 @@ let or_clause_cnf unsat deduce t0 f = | None -> acc) [] f (** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 - cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) let rec or_cnf unsat deduce f f' = match f with - | [] -> tt + | [] -> cnf_tt | e::rst -> app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') -(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) +(** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) let and_cnf = app +type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula + (** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) + tFormula -> ('a2, 'a3) cnf **) let rec xcnf unsat deduce normalise0 negate0 pol0 = function -| TT -> if pol0 then tt else ff -| FF -> if pol0 then ff else tt -| X -> ff -| A x -> if pol0 then normalise0 x else negate0 x +| TT -> if pol0 then cnf_tt else cnf_ff +| FF -> if pol0 then cnf_ff else cnf_tt +| X _ -> cnf_ff +| A (x, t0) -> if pol0 then normalise0 x t0 else negate0 x t0 | Cj (e1, e2) -> if pol0 then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) @@ -1006,7 +1086,7 @@ let rec xcnf unsat deduce normalise0 negate0 pol0 = function else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) | N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e -| I (e1, e2) -> +| I (e1, _, e2) -> if pol0 then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) @@ -1014,8 +1094,95 @@ let rec xcnf unsat deduce normalise0 negate0 pol0 = function else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) (xcnf unsat deduce normalise0 negate0 pol0 e2) +(** val radd_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) + clause -> (('a1, 'a2) clause, 'a2 list) sum **) + +let rec radd_term unsat deduce t0 = function +| [] -> + (match deduce (fst t0) (fst t0) with + | Some u -> if unsat u then Inr ((snd t0)::[]) else Inl (t0::[]) + | None -> Inl (t0::[])) +| t'::cl0 -> + (match deduce (fst t0) (fst t') with + | Some u -> + if unsat u + then Inr ((snd t0)::((snd t')::[])) + else (match radd_term unsat deduce t0 cl0 with + | Inl cl' -> Inl (t'::cl') + | Inr l -> Inr l) + | None -> + (match radd_term unsat deduce t0 cl0 with + | Inl cl' -> Inl (t'::cl') + | Inr l -> Inr l)) + +(** val ror_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause -> (('a1, 'a2) clause, 'a2 list) sum **) + +let rec ror_clause unsat deduce cl1 cl2 = + match cl1 with + | [] -> Inl cl2 + | t0::cl -> + (match radd_term unsat deduce t0 cl2 with + | Inl cl' -> ror_clause unsat deduce cl cl' + | Inr l -> Inr l) + +(** val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause list -> ('a1, 'a2) clause list * 'a2 list **) + +let ror_clause_cnf unsat deduce t0 f = + fold_right (fun e pat -> + let acc,tg = pat in + (match ror_clause unsat deduce t0 e with + | Inl cl -> (cl::acc),tg + | Inr l -> acc,(app tg l))) ([],[]) f + +(** val ror_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> + ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 list **) + +let rec ror_cnf unsat deduce f f' = + match f with + | [] -> cnf_tt,[] + | e::rst -> + let rst_f',t0 = ror_cnf unsat deduce rst f' in + let e_f',t' = ror_clause_cnf unsat deduce e f' in + (app rst_f' e_f'),(app t0 t') + +(** val rxcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) + tFormula -> ('a2, 'a3) cnf * 'a3 list **) + +let rec rxcnf unsat deduce normalise0 negate0 polarity = function +| TT -> if polarity then cnf_tt,[] else cnf_ff,[] +| FF -> if polarity then cnf_ff,[] else cnf_tt,[] +| X _ -> cnf_ff,[] +| A (x, t0) -> (if polarity then normalise0 x t0 else negate0 x t0),[] +| Cj (e1, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then (app e3 e4),(app t1 t2) + else let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) +| D (e1, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + else (app e3 e4),(app t1 t2) +| N e -> rxcnf unsat deduce normalise0 negate0 (negb polarity) e +| I (e1, _, e2) -> + let e3,t1 = rxcnf unsat deduce normalise0 negate0 (negb polarity) e1 in + let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + if polarity + then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + else (and_cnf e3 e4),(app t1 t2) + (** val cnf_checker : - ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) + (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) let rec cnf_checker checker f l = match f with @@ -1026,9 +1193,9 @@ let rec cnf_checker checker f l = | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> - bool **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) + cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> + bool) -> ('a1, __, 'a3, unit0) gFormula -> 'a4 list -> bool **) let tauto_checker unsat deduce normalise0 negate0 checker f w = cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w @@ -1243,11 +1410,12 @@ let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = (** 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 -> bool) -> 'a1 formula -> 'a2 -> + ('a1 nFormula, 'a2) cnf **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 tg = + map (fun x -> (x,tg)::[]) + (xnormalise cO cI cplus ctimes cminus copp ceqb t0) (** val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 @@ -1271,11 +1439,11 @@ let xnegate cO cI cplus ctimes cminus copp ceqb t0 = (** 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 -> bool) -> 'a1 formula -> 'a2 -> + ('a1 nFormula, 'a2) cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) +let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 tg = + map (fun x -> (x,tg)::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) @@ -1366,6 +1534,13 @@ let simpl_cone cO cI ctimes ceqb e = match e with | _ -> PsatzAdd (t1, t2))) | _ -> e +module PositiveSet = + struct + type tree = + | Leaf + | Node of tree * bool * tree + end + type q = { qnum : z; qden : positive } (** val qnum : q -> z **) @@ -1429,16 +1604,16 @@ let qpower q0 = function type 'a t = | Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t +| Elt of 'a +| Branch of 'a t * 'a * 'a t (** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) let rec find default vm p = match vm with | Empty -> default - | Leaf i -> i - | Node (l, e, r) -> + | Elt i -> i + | Branch (l, e, r) -> (match p with | XI p2 -> find default r p2 | XO p2 -> find default l p2 @@ -1448,24 +1623,24 @@ let rec find default vm p = let rec singleton default x v = match x with - | XI p -> Node (Empty, default, (singleton default p v)) - | XO p -> Node ((singleton default p v), default, Empty) - | XH -> Leaf v + | XI p -> Branch (Empty, default, (singleton default p v)) + | XO p -> Branch ((singleton default p v), default, Empty) + | XH -> Elt v (** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) let rec vm_add default x v = function | Empty -> singleton default x v -| Leaf vl -> +| Elt vl -> (match x with - | XI p -> Node (Empty, vl, (singleton default p v)) - | XO p -> Node ((singleton default p v), vl, Empty) - | XH -> Leaf v) -| Node (l, o, r) -> + | XI p -> Branch (Empty, vl, (singleton default p v)) + | XO p -> Branch ((singleton default p v), vl, Empty) + | XH -> Elt v) +| Branch (l, o, r) -> (match x with - | XI p -> Node (l, o, (vm_add default p v r)) - | XO p -> Node ((vm_add default p v l), o, r) - | XH -> Node (l, v, r)) + | XI p -> Branch (l, o, (vm_add default p v r)) + | XO p -> Branch ((vm_add default p v l), o, r) + | XH -> Branch (l, v, r)) type zWitness = z psatz @@ -1507,10 +1682,10 @@ let xnormalise0 t0 = | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) -(** val normalise : z formula -> z nFormula cnf **) +(** val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let normalise t0 = - map (fun x -> x::[]) (xnormalise0 t0) +let normalise t0 tg = + map (fun x -> (x,tg)::[]) (xnormalise0 t0) (** val xnegate0 : z formula -> z nFormula list **) @@ -1530,10 +1705,10 @@ let xnegate0 t0 = | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) -(** val negate : z formula -> z nFormula cnf **) +(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let negate t0 = - map (fun x -> x::[]) (xnegate0 t0) +let negate t0 tg = + map (fun x -> (x,tg)::[]) (xnegate0 t0) (** val zunsat : z nFormula -> bool **) @@ -1545,6 +1720,12 @@ let zunsat = let zdeduce = nformula_plus_nformula Z0 Z.add zeq_bool +(** val cnfZ : + (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list **) + +let cnfZ f = + rxcnf zunsat zdeduce normalise negate true f + (** val ceiling : z -> z -> z **) let ceiling a b = @@ -1629,6 +1810,145 @@ let valid_cut_sign = function | NonStrict -> true | _ -> false +module Vars = + struct + type elt = positive + + type tree = PositiveSet.tree = + | Leaf + | Node of tree * bool * tree + + type t = tree + + (** val empty : t **) + + let empty = + Leaf + + (** val add : elt -> t -> t **) + + let rec add i = function + | Leaf -> + (match i with + | XI i0 -> Node (Leaf, false, (add i0 Leaf)) + | XO i0 -> Node ((add i0 Leaf), false, Leaf) + | XH -> Node (Leaf, true, Leaf)) + | Node (l, o, r) -> + (match i with + | XI i0 -> Node (l, o, (add i0 r)) + | XO i0 -> Node ((add i0 l), o, r) + | XH -> Node (l, true, r)) + + (** val singleton : elt -> t **) + + let singleton i = + add i empty + + (** val union : t -> t -> t **) + + let rec union m m' = + match m with + | Leaf -> m' + | Node (l, o, r) -> + (match m' with + | Leaf -> m + | Node (l', o', r') -> + Node ((union l l'), (if o then true else o'), (union r r'))) + + (** val rev_append : elt -> elt -> elt **) + + let rec rev_append y x = + match y with + | XI y0 -> rev_append y0 (XI x) + | XO y0 -> rev_append y0 (XO x) + | XH -> x + + (** val rev : elt -> elt **) + + let rev x = + rev_append x XH + + (** val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 **) + + let rec xfold f m v i = + match m with + | Leaf -> v + | Node (l, b, r) -> + if b + then xfold f r (f (rev i) (xfold f l v (XO i))) (XI i) + else xfold f r (xfold f l v (XO i)) (XI i) + + (** val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 **) + + let fold f m i = + xfold f m i XH + end + +(** val vars_of_pexpr : z pExpr -> Vars.t **) + +let rec vars_of_pexpr = function +| PEc _ -> Vars.empty +| PEX x -> Vars.singleton x +| PEadd (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEsub (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEmul (e1, e2) -> + let v1 = vars_of_pexpr e1 in let v2 = vars_of_pexpr e2 in Vars.union v1 v2 +| PEopp c -> vars_of_pexpr c +| PEpow (e0, _) -> vars_of_pexpr e0 + +(** val vars_of_formula : z formula -> Vars.t **) + +let vars_of_formula f = + let { flhs = l; fop = _; frhs = r } = f in + let v1 = vars_of_pexpr l in let v2 = vars_of_pexpr r in Vars.union v1 v2 + +(** val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t **) + +let rec vars_of_bformula = function +| A (a, _) -> vars_of_formula a +| Cj (f1, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| D (f1, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| N f0 -> vars_of_bformula f0 +| I (f1, _, f2) -> + let v1 = vars_of_bformula f1 in + let v2 = vars_of_bformula f2 in Vars.union v1 v2 +| _ -> Vars.empty + +(** val bound_var : positive -> z formula **) + +let bound_var v = + { flhs = (PEX v); fop = OpGe; frhs = (PEc Z0) } + +(** val mk_eq_pos : positive -> positive -> positive -> z formula **) + +let mk_eq_pos x y t0 = + { flhs = (PEX x); fop = OpEq; frhs = (PEsub ((PEX y), (PEX t0))) } + +(** val bound_vars : + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z + formula, 'a1, 'a2, 'a3) gFormula **) + +let bound_vars tag_of_var fr v = + Vars.fold (fun k acc -> + let y = XO (Coq_Pos.add fr k) in + let z0 = XI (Coq_Pos.add fr k) in + Cj ((Cj ((A ((mk_eq_pos k y z0), (tag_of_var fr k None))), (Cj ((A + ((bound_var y), (tag_of_var fr k (Some false)))), (A ((bound_var z0), + (tag_of_var fr k (Some true)))))))), acc)) v TT + +(** val bound_problem_fr : + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, + 'a1, 'a2, 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula **) + +let bound_problem_fr tag_of_var fr f = + let v = vars_of_bformula f in I ((bound_vars tag_of_var fr v), None, f) + (** val zChecker : z nFormula list -> zArithProof -> bool **) let rec zChecker l = function @@ -1675,7 +1995,8 @@ let rec zChecker l = function (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise negate zChecker f w + tauto_checker zunsat zdeduce normalise negate (fun cl -> + zChecker (map fst cl)) f w type qWitness = q psatz @@ -1685,17 +2006,17 @@ let qWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool -(** val qnormalise : q formula -> q nFormula cnf **) +(** val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let qnormalise = +let qnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool + qplus qmult qminus qopp qeq_bool t0 tg -(** val qnegate : q formula -> q nFormula cnf **) +(** val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let qnegate = +let qnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + qmult qminus qopp qeq_bool t0 tg (** val qunsat : q nFormula -> bool **) @@ -1713,10 +2034,17 @@ let normQ = norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool +(** val cnfQ : + (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list **) + +let cnfQ f = + rxcnf qunsat qdeduce qnormalise qnegate true f + (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = - tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w + tauto_checker qunsat qdeduce qnormalise qnegate (fun cl -> + qWeakChecker (map fst cl)) f w type rcst = | C0 @@ -1726,9 +2054,16 @@ type rcst = | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst +| CPow of rcst * (z, nat) sum | CInv of rcst | COpp of rcst +(** val z_of_exp : (z, nat) sum -> z **) + +let z_of_exp = function +| Inl z1 -> z1 +| Inr n0 -> Z.of_nat n0 + (** val q_of_Rcst : rcst -> q **) let rec q_of_Rcst = function @@ -1739,6 +2074,7 @@ let rec q_of_Rcst = function | CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) | CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) | CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) +| CPow (r1, z0) -> qpower (q_of_Rcst r1) (z_of_exp z0) | CInv r0 -> qinv (q_of_Rcst r0) | COpp r0 -> qopp (q_of_Rcst r0) @@ -1750,17 +2086,17 @@ let rWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qeq_bool qle_bool -(** val rnormalise : q formula -> q nFormula cnf **) +(** val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let rnormalise = +let rnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool + qplus qmult qminus qopp qeq_bool t0 tg -(** val rnegate : q formula -> q nFormula cnf **) +(** val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) -let rnegate = +let rnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + qmult qminus qopp qeq_bool t0 tg (** val runsat : q nFormula -> bool **) @@ -1775,5 +2111,5 @@ let rdeduce = (** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) let rTautoChecker f w = - tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker - (map_bformula (map_Formula q_of_Rcst) f) w + tauto_checker runsat rdeduce rnormalise rnegate (fun cl -> + rWeakChecker (map fst cl)) (map_bformula (map_Formula q_of_Rcst) f) w diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 72c2bf7da3..5de6caac0b 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,10 +1,23 @@ +type __ = Obj.t + +type unit0 = +| Tt + val negb : bool -> bool type nat = | O | S of nat +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +val fst : ('a1 * 'a2) -> 'a1 + +val snd : ('a1 * 'a2) -> 'a2 + val app : 'a1 list -> 'a1 list -> 'a1 list type comparison = @@ -16,6 +29,12 @@ val compOpp : comparison -> comparison val add : nat -> nat -> nat +val nth : nat -> 'a1 list -> 'a1 -> 'a1 + +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list + +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 + type positive = | XI of positive | XO of positive @@ -87,12 +106,6 @@ module N : val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -val nth : nat -> 'a1 list -> 'a1 -> 'a1 - -val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list - -val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 - module Z : sig val double : z -> z @@ -125,6 +138,8 @@ module Z : val to_N : z -> n + val of_nat : nat -> z + val pos_div_eucl : positive -> z -> z * z val div_eucl : z -> z -> z * z @@ -163,27 +178,47 @@ 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 @@ -197,49 +232,104 @@ 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 = +type ('tA, 'tX, 'aA, 'aF) gFormula = | TT | FF -| X -| A of 'a -| Cj of 'a bFormula * 'a bFormula -| D of 'a bFormula * 'a bFormula -| N of 'a bFormula -| I of 'a bFormula * 'a bFormula +| X of 'tX +| A of 'tA * 'aA +| Cj of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| D of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| N of ('tA, 'tX, 'aA, 'aF) gFormula +| I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula + +val mapX : + ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula + +val foldA : ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 + +val cons_id : 'a1 option -> 'a1 list -> 'a1 list + +val ids_of_formula : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list + +val collect_annot : ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list + +type 'a bFormula = ('a, __, unit0, unit0) gFormula + +val map_bformula : + ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula + +type ('x, 'annot) clause = ('x * 'annot) list + +type ('x, 'annot) cnf = ('x, 'annot) clause list + +val cnf_tt : ('a1, 'a2) cnf -val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula +val cnf_ff : ('a1, 'a2) cnf -type 'x clause = 'x list +val add_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> + ('a1, 'a2) clause option -type 'x cnf = 'x clause list +val or_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause -> ('a1, 'a2) clause option -val tt : 'a1 cnf +val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf + -> ('a1, 'a2) cnf -val ff : 'a1 cnf +val or_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> + ('a1, 'a2) cnf -val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option +val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option +type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula -val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf +val xcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, + 'a3) cnf -val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val radd_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> + (('a1, 'a2) clause, 'a2 list) sum -val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val ror_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause + -> (('a1, 'a2) clause, 'a2 list) sum -val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf +val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause + list -> ('a1, 'a2) clause list * 'a2 list -val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool +val ror_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> ('a1, 'a2) + clause list -> ('a1, 'a2) cnf * 'a2 list + +val rxcnf : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, + 'a3) cnf * 'a3 list + +val cnf_checker : + (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 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 -> 'a3 -> ('a2, 'a3) cnf) -> + ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, + 'a3, unit0) gFormula -> 'a4 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -273,21 +363,27 @@ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 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 - nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option -val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool +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 @@ -300,27 +396,31 @@ 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 -> 'a2 -> ('a1 nFormula, 'a2) 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 -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -330,7 +430,15 @@ 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 + +module PositiveSet : + sig + type tree = + | Leaf + | Node of tree * bool * tree + end type q = { qnum : z; qden : positive } @@ -358,8 +466,8 @@ val qpower : q -> z -> q type 'a t = | Empty -| Leaf of 'a -| Node of 'a t * 'a * 'a t +| Elt of 'a +| Branch of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 @@ -379,16 +487,18 @@ val normZ : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list -val normalise : z formula -> z nFormula cnf +val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf val xnegate0 : z formula -> z nFormula list -val negate : z formula -> z nFormula cnf +val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf val zunsat : z nFormula -> bool val zdeduce : z nFormula -> z nFormula -> z nFormula option +val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list + val ceiling : z -> z -> z type zArithProof = @@ -415,6 +525,51 @@ val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option val valid_cut_sign : op1 -> bool +module Vars : + sig + type elt = positive + + type tree = PositiveSet.tree = + | Leaf + | Node of tree * bool * tree + + type t = tree + + val empty : t + + val add : elt -> t -> t + + val singleton : elt -> t + + val union : t -> t -> t + + val rev_append : elt -> elt -> elt + + val rev : elt -> elt + + val xfold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> elt -> 'a1 + + val fold : (elt -> 'a1 -> 'a1) -> t -> 'a1 -> 'a1 + end + +val vars_of_pexpr : z pExpr -> Vars.t + +val vars_of_formula : z formula -> Vars.t + +val vars_of_bformula : (z formula, 'a1, 'a2, 'a3) gFormula -> Vars.t + +val bound_var : positive -> z formula + +val mk_eq_pos : positive -> positive -> positive -> z formula + +val bound_vars : + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, + 'a1, 'a2, 'a3) gFormula + +val bound_problem_fr : + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, + 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula + val zChecker : z nFormula list -> zArithProof -> bool val zTautoChecker : z formula bFormula -> zArithProof list -> bool @@ -423,9 +578,9 @@ type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool -val qnormalise : q formula -> q nFormula cnf +val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf -val qnegate : q formula -> q nFormula cnf +val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf val qunsat : q nFormula -> bool @@ -433,6 +588,8 @@ val qdeduce : q nFormula -> q nFormula -> q nFormula option val normQ : q pExpr -> q pol +val cnfQ : (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list + val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = @@ -443,18 +600,21 @@ type rcst = | CPlus of rcst * rcst | CMinus of rcst * rcst | CMult of rcst * rcst +| CPow of rcst * (z, nat) sum | CInv of rcst | COpp of rcst +val z_of_exp : (z, nat) sum -> z + val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool -val rnormalise : q formula -> q nFormula cnf +val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf -val rnegate : q formula -> q nFormula cnf +val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf val runsat : q nFormula -> bool diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 809731ecc4..084ea39c27 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,8 +19,18 @@ (* *) (************************************************************************) +module Int = struct + type t = int + let compare : int -> int -> int = Pervasives.compare + let equal : int -> int -> bool = (=) +end -module ISet = Set.Make(Int) +module ISet = + struct + include Set.Make(Int) + + let pp o s = iter (fun i -> Printf.fprintf o "%i " i) s + end module IMap = struct @@ -82,12 +92,69 @@ let extract pred l = | _ -> (fd, e::sys) ) (None,[]) l +let extract_best red lt l = + let rec extractb c e rst l = + match l with + [] -> Some (c,e) , rst + | e'::l' -> match red e' with + | None -> extractb c e (e'::rst) l' + | Some c' -> if lt c' c + then extractb c' e' (e::rst) l' + else extractb c e (e'::rst) l' in + match extract red l with + | None , _ -> None,l + | Some(c,e), rst -> extractb c e [] rst + + +let rec find_some pred l = + match l with + | [] -> None + | e::l -> match pred e with + | Some r -> Some r + | None -> find_some pred 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 +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 generate_acc f acc sys = + List.fold_left (fun sys' c -> match f c with + | None -> sys' + | Some c' -> c'::sys' + ) acc sys + + +let generate f sys = generate_acc f [] sys + + +let saturate p f sys = + let rec sat acc l = + match extract p l with + | None,_ -> acc + | Some r,l' -> + let n = generate (f r) (l'@acc) in + sat (n@acc) l' in + try sat [] sys with + x -> + begin + Printexc.print_backtrace stdout ; + raise x + end + + open Num open Big_int @@ -276,7 +343,8 @@ sig val next : t -> t val pp : out_channel -> t -> unit val compare : t -> t -> int - + val max : t -> t -> t + val to_int : t -> int end module Tag : Tag = @@ -286,8 +354,10 @@ struct let from i = i let next i = i + 1 + let max : int -> int -> int = Pervasives.max let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Int.compare + let to_int x = x end diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index e92f086886..739d1a73da 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -8,8 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module Int : sig type t = int val compare : int -> int -> int val equal : int -> int -> bool end -module ISet : Set.S with type elt = int + +module ISet : sig + include Set.S with type elt = int + val pp : out_channel -> t -> unit +end module IMap : sig @@ -36,7 +41,9 @@ module Tag : sig val pp : out_channel -> t -> unit val next : t -> t + val max : t -> t -> t val from : int -> t + val to_int : t -> int end @@ -78,8 +85,18 @@ 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 extract_best : ('a -> 'b option) -> ('b -> 'b -> bool) -> 'a list -> ('b *'a) option * 'a list + +val find_some : ('a -> 'b option) -> 'a list -> 'b option + val iterate_until_stable : ('a -> 'a option) -> 'a -> 'a +val simplify : ('a -> 'a option) -> 'a list -> 'a list option + +val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list + +val generate : ('a -> 'b option) -> 'a list -> 'b list + 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 76e7769e82..d406560fb8 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -378,6 +378,7 @@ module LinPoly = struct let pp o p = Vect.pp_gen pp_var o p + let constant c = if sign_num c = 0 then Vect.null @@ -389,6 +390,12 @@ module LinPoly = struct let mn = (MonT.retrieve v) in Monomial.is_var mn || Monomial.is_const mn) p + let is_variable p = + let ((x,v),r) = Vect.decomp_fst p in + if Vect.is_null r && v >/ Int 0 + then Monomial.get_var (MonT.retrieve x) + else None + let factorise x p = let (px,cx) = Poly.factorise x (pol_of_linpol p) in @@ -399,20 +406,6 @@ module LinPoly = struct 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 @@ -426,12 +419,24 @@ module LinPoly = struct else acc else acc) [] l + let min_list (l:int list) = + match l with + | [] -> None + | e::l -> Some (List.fold_left Pervasives.min e l) + + let search_linear p l = + min_list (search_all_linear p 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 of_vect v = + Vect.fold (fun acc v vl -> addition (product (var v) (constant vl)) acc) Vect.null v + let variables p = Vect.fold (fun acc v _ -> ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p @@ -489,8 +494,8 @@ module ProofFormat = struct | 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 + | 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) @@ -502,6 +507,18 @@ module ProofFormat = struct output_prf_rule p1 Vect.pp v output_prf_rule p2 (pp_list ";" output_proof) pl + let rec pr_size = function + | Annot(_,p) -> pr_size p + | Zero| Square _ -> Int 0 + | Hyp _ -> Int 1 + | Def _ -> Int 1 + | Cst n -> n + | Gcd(i, p) -> pr_size p // (Big_int i) + | MulPrf(p1,p2) | AddPrf(p1,p2) -> pr_size p1 +/ pr_size p2 + | CutPrf p -> pr_size p + | MulC(v, p) -> pr_size p + + let rec pr_rule_max_id = function | Annot(_,p) -> pr_rule_max_id p | Hyp i | Def i -> i @@ -613,6 +630,48 @@ module ProofFormat = struct if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; res + module OrdPrfRule = + struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1,x2) (y1,y2) = + match c1 x1 y1 with + | 0 -> c2 x2 y2 + | i -> i + + + let rec compare p1 p2 = + match p1, p2 with + | Annot(s1,p1) , Annot(s2,p2) -> if s1 = s2 then compare p1 p2 + else Pervasives.compare s1 s2 + | Hyp i , Hyp j -> Pervasives.compare i j + | Def i , Def j -> Pervasives.compare i j + | Cst n , Cst m -> Num.compare_num n m + | Zero , Zero -> 0 + | Square v1 , Square v2 -> Vect.compare v1 v2 + | MulC(v1,p1) , MulC(v2,p2) -> cmp_pair Vect.compare compare (v1,p1) (v2,p2) + | Gcd(b1,p1) , Gcd(b2,p2) -> cmp_pair Big_int.compare_big_int compare (b1,p1) (b2,p2) + | MulPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) + | AddPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) + | CutPrf p , CutPrf p' -> compare p p' + | _ , _ -> Pervasives.compare (id_of_constr p1) (id_of_constr p2) + + end + + let add_proof x y = @@ -621,23 +680,91 @@ module ProofFormat = struct | _ -> 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 rec mul_cst_proof c p = + match p with + | Annot(s,p) -> Annot(s,mul_cst_proof c p) + | MulC(v,p') -> MulC(Vect.mul c v,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 sMulC v p = + let (c,v') = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p + else MulC(v,p) let mul_proof p1 p2 = match p1 , p2 with | Zero , _ | _ , Zero -> Zero - | Cst (Int 1) , p | p , Cst (Int 1) -> p - | _ , _ -> MulPrf(p1,p2) + | Cst c , p | p , Cst c -> mul_cst_proof c p + | _ , _ -> + MulPrf(p1,p2) + + module PrfRuleMap = Map.Make(OrdPrfRule) + + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero + + + let rec dev_prf_rule p = + match p with + | Annot(s,p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + | MulC(v,p) -> PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf(p1,p2) -> PrfRuleMap.merge (fun k o1 o2 -> + match o1 , o2 with + | None , None -> None + | None , Some v | Some v, None -> Some v + | Some v1 , Some v2 -> Some (LinPoly.addition v1 v2)) (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf(p1, p2) -> + begin + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> PrfRuleMap.singleton (MulPrf(p1'',p2'')) (LinPoly.constant (Int 1)) + end + | _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + + let simplify_prf_rule p = + prf_rule_of_map (dev_prf_rule p) + + + (* + let mul_proof p1 p2 = + let res = mul_proof p1 p2 in + Printf.printf "mul_proof %a %a = %a\n" + output_prf_rule p1 output_prf_rule p2 output_prf_rule res; res + + let add_proof p1 p2 = + let res = add_proof p1 p2 in + Printf.printf "add_proof %a %a = %a\n" + output_prf_rule p1 output_prf_rule p2 output_prf_rule res; res + + + let sMulC v p = + let res = sMulC v p in + Printf.printf "sMulC %a %a = %a\n" Vect.pp v output_prf_rule p output_prf_rule res ; + res + + let mul_cst_proof c p = + let res = mul_cst_proof c p in + Printf.printf "mul_cst_proof %s %a = %a\n" (Num.string_of_num c) output_prf_rule p output_prf_rule res ; + res + *) let proof_of_farkas env vect = Vect.fold (fun prf x n -> @@ -645,6 +772,7 @@ module ProofFormat = struct + module Env = struct let rec string_of_int_list l = @@ -768,10 +896,14 @@ module WithProof = struct 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 output_sys o l = + List.iter (Printf.fprintf o "%a\n" output) l + exception InvalidProof let zero = ((Vect.null,Eq), ProofFormat.Zero) + let const n = ((LinPoly.constant n,Ge), ProofFormat.Cst n) let of_cstr (c,prf) = (Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf @@ -784,7 +916,7 @@ module WithProof = struct let mult p ((p1,o1),prf1) = match o1 with - | Eq -> ((LinPoly.product p p1,o1), ProofFormat.MulC(p, prf1)) + | Eq -> ((LinPoly.product p p1,o1), ProofFormat.sMulC 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) @@ -890,6 +1022,51 @@ module WithProof = struct end | (Ge|Gt) , Eq -> failwith "pivot: equality as second argument" + let linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = + match linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) with + | None -> None + | Some (c,p) -> Some(c, ProofFormat.simplify_prf_rule p) + + +let is_substitution strict ((p,o),prf) = + let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in + + match o with + | Eq -> LinPoly.search_linear pred p + | _ -> None + + +let subst1 sys0 = + let (oeq,sys') = extract (is_substitution true) sys0 in + match oeq with + | None -> sys0 + | Some(v,pc) -> + match simplify (linear_pivot sys0 pc v) sys' with + | None -> sys0 + | Some sys' -> sys' + + + +let subst sys0 = + let elim sys = + let (oeq,sys') = extract (is_substitution true) sys in + match oeq with + | None -> None + | Some(v,pc) -> simplify (linear_pivot sys0 pc v) sys' in + + iterate_until_stable elim sys0 + + +let saturate_subst b sys0 = + let select = is_substitution b in + let gen (v,pc) ((c,op),prf) = + if ISet.mem v (LinPoly.variables c) + then linear_pivot sys0 pc v ((c,op),prf) + else None + in + saturate select gen sys0 + + end diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 23f3470d77..b5c6fefbb5 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -28,6 +28,8 @@ module Monomial : sig @return the empty monomial i.e. without any variable *) val const : t + val is_const : t -> bool + (** [var x] @return the monomial x^1 *) val var : var -> t @@ -40,6 +42,11 @@ module Monomial : sig @return [true] iff m = x^1 for some variable x *) val is_var : t -> bool + (** [get_var m] + @return [x] iff m = x^1 for variable x *) + val get_var : t -> var option + + (** [div m1 m2] @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) val div : t -> t -> t * int @@ -141,6 +148,10 @@ module LinPoly : sig @return the monomial corresponding to the variable [x] *) val retrieve : int -> Monomial.t + (** [register m] + @return the variable index for the monomial m *) + val register : Monomial.t -> int + end (** [linpol_of_pol p] linearise the polynomial p *) @@ -161,11 +172,21 @@ module LinPoly : sig @returns 1.x where x is the variable (index) for monomial m *) val of_monomial : Monomial.t -> t + (** [of_vect v] + @returns a1.x1 + ... + an.xn + This is not the identity because xi is the variable index of xi^1 + *) + val of_vect : Vect.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_variable p] + @return Some x if p = a.x for a >= 0 *) + val is_variable : t -> var option + (** [is_linear p] @return whether the multi-variate polynomial is linear. *) val is_linear : t -> bool @@ -245,6 +266,8 @@ module ProofFormat : sig | Step of int * prf_rule * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list + val pr_size : prf_rule -> Num.num + val pr_rule_max_id : prf_rule -> int val proof_max_id : proof -> int @@ -294,9 +317,14 @@ sig (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) val output : out_channel -> t -> unit + val output_sys : out_channel -> t list -> unit + (** [zero] represents the tautology (0=0) *) val zero : t + (** [const n] represents the tautology (n>=0) *) + val const : Num.num -> t + (** [product p q] @return the polynomial p*q with its sign and proof *) val product : t -> t -> t @@ -321,4 +349,24 @@ sig *) val linear_pivot : t list -> t -> Vect.var -> t -> t option + +(** [subst sys] performs the equivalent of the 'subst' tactic of Coq. + For every p=0 \in sys such that p is linear in x with coefficient +/- 1 + i.e. p = 0 <-> x = e and x \notin e. + Replace x by e in sys + + NB: performing this transformation may hinders the non-linear prover to find a proof. + [elim_simple_linear_equality] is much more careful. + *) + + val subst : t list -> t list + + (** [subst1 sys] performs a single substitution *) + val subst1 : t list -> t list + + val saturate_subst : bool -> t list -> t list + + + val is_substitution : bool -> t -> var option + end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 4465aa1ee1..4ddeb6c2c0 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -11,9 +11,11 @@ (** A naive simplex *) open Polynomial open Num -open Util +(*open Util*) open Mutils +type ('a,'b) sum = Inl of 'a | Inr of 'b + let debug = false type iset = unit IMap.t @@ -130,12 +132,6 @@ let is_maximised rst v = 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 *) @@ -335,6 +331,8 @@ let normalise_row (t : tableau) (v: Vect.t) = 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 @@ -361,7 +359,7 @@ let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tabl 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 +(** One complication is that equalities needs some pre-processing. *) open Mutils open Polynomial @@ -406,25 +404,21 @@ let find_solution rst tbl = 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 most_violating l e (x,v) rst = + match l with + | [] -> Some((x,v),rst) + | (x',v')::l -> + let e' = Vect.dotproduct esol v' in + if e' <=/ e + then most_violating l e' (x',v') ((x,v)::rst) + else most_violating l e (x,v) ((x',v')::rst) in + + match l with + | [] -> None + | (x,v)::l -> let e = Vect.dotproduct esol v in + most_violating l e (x,v) [] + let rec solve opt l (rst:Restricted.t) (t:tableau) = @@ -515,65 +509,117 @@ let make_farkas_proof (env: WithProof.t IMap.t) vm v = 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 frac_num n = n -/ Num.floor_num n - let nf = Num.floor_num n in - if nf =/ n + +(* [resolv_var v rst tbl] returns (if it exists) a restricted variable vr such that v = vr *) +exception FoundVar of int + +let resolve_var v rst tbl = + let v = Vect.set v (Int 1) Vect.null in + try + IMap.iter (fun k vect -> + if Restricted.is_restricted k rst + then if Vect.equal v vect then raise (FoundVar k) + else ()) tbl ; None + with FoundVar k -> Some k + +let prepare_cut env rst tbl x v = + (* extract the unrestricted part *) + let (unrst,rstv) = Vect.partition (fun x vl -> not (Restricted.is_restricted x rst) && frac_num vl <>/ Int 0) (Vect.set 0 (Int 0) v) in + if Vect.is_null unrst + then Some rstv + else Some (Vect.fold (fun acc k i -> + match resolve_var k rst tbl with + | None -> acc (* Should not happen *) + | Some v' -> Vect.set v' i acc) + rstv unrst) + +let cut env rmin sol vm (rst:Restricted.t) tbl (x,v) = + begin + (* Printf.printf "Trying to cut %i\n" x;*) + let (n,r) = Vect.decomp_cst v in + + + let f = frac_num n in + + if f =/ Int 0 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 t = + if f </ (Int 1) // (Int 2) + then + let t' = ((Int 1) // f) in + if Num.is_integer_num t' + then t' -/ Int 1 + else Num.floor_num t' + else Int 1 in + + let cut_coeff1 v = + let fv = frac_num v in + if fv <=/ (Int 1 -/ f) + then fv // (Int 1 -/ f) + else (Int 1 -/ fv) // f in + + let cut_coeff2 v = frac_num (t */ v) in + + let cut_vector ccoeff = + match prepare_cut env rst tbl x v with + | None -> Vect.null + | Some r -> + (*Printf.printf "Potential cut %a\n" LinPoly.pp r;*) + Vect.fold (fun acc x n -> Vect.set x (ccoeff n) acc) Vect.null r + in + + let lcut = List.map (fun cv -> Vect.normalise (cut_vector cv)) [cut_coeff1 ; cut_coeff2] in + + let lcut = List.map (make_farkas_proof env vm) lcut in + + let check_cutting_plane c = + match WithProof.cutting_plane c with + | None -> + if debug then Printf.printf "This is not cutting plane for %a\n%a:" LinPoly.pp_var x WithProof.output c; + None + | Some(v,prf) -> + if debug then begin + Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; + Printf.printf " %a\n" WithProof.output (v,prf); + end; + if Pervasives.(=) (snd v) Eq + then (* Unsat *) Some (x,(v,prf)) + else + let vl = (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) in + if eval_op Ge vl (Int 0) + then begin + (* Can this happen? *) + if debug then Printf.printf "The cut is feasible %s >= 0 ??\n" (Num.string_of_num vl); + None + end + else Some(x,(v,prf)) in + + find_some check_cutting_plane lcut + end + +let find_cut nb env u sol vm rst tbl = + if nb = 0 + then + IMap.fold (fun x v acc -> + match acc with + | None -> cut env u sol vm rst tbl (x,v) + | Some c -> Some c) tbl None + else + IMap.fold (fun x v acc -> + match cut env u sol vm rst tbl (x,v) , acc with + | None , Some r | Some r , None -> Some r + | None , None -> None + | Some (v,((lp,o),p1)) , Some (v',((lp',o'),p2)) -> + Some (if ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 + then (v,((lp,o),p1)) else (v',((lp',o'),p2))) + ) tbl None + + let integer_solver lp = let (l,_) = List.split lp in @@ -587,7 +633,10 @@ let integer_solver lp = | Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x) | Unsat c -> Inr c in + let nb = ref 0 in + let rec isolve env cr vr res = + incr nb; match res with | Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done)) | Inl (rst,tbl,x) -> @@ -595,10 +644,11 @@ let integer_solver lp = 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; + (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) end; let sol = find_solution rst tbl in - match find_cut env cr (*x*) sol vm rst tbl with + match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with | None -> None | Some(cr,((v,op),cut)) -> if Pervasives.(=) op Eq @@ -615,6 +665,8 @@ let integer_solver lp = isolve env None vr res let integer_solver lp = + if debug then Printf.printf "Input integer solver\n%a\n" WithProof.output_sys (List.map WithProof.of_cstr lp); + match integer_solver lp with | None -> None | Some prf -> if debug diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index b188ab4278..b80d5536eb 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -54,6 +54,17 @@ let pp_var_num pp_var o (v,n) = | Int 0 -> () | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v +let pp_var_num_smt 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 @@ -66,6 +77,9 @@ let pp_var o v = Printf.fprintf o "x%i" v let pp o v = pp_gen pp_var o v +let pp_smt o v = + let list o v = List.iter (fun e -> Printf.fprintf o "%a " (pp_var_num_smt pp_var) e) v in + Printf.fprintf o "(+ %a)" list v let from_list (l: num list) = let rec xfrom_list i l = @@ -222,6 +236,19 @@ let decomp_cst v = | (0,vl)::v -> vl,v | _ -> Int 0,v +let rec decomp_at i v = + match v with + | [] -> (Int 0 , null) + | (vr,vl)::r -> if i = vr then (vl,r) + else if i < vr then (Int 0,v) + else decomp_at i r + +let decomp_fst v = + match v with + | [] -> ((0,Int 0),[]) + | x::v -> (x,v) + + let fold f acc v = List.fold_left (fun acc (v,i) -> f acc v i) acc v @@ -293,3 +320,19 @@ let dotproduct v1 v2 = then dot acc v1' v2 else dot acc v1 v2' in dot (Int 0) v1 v2 + + +let map f v = List.map (fun (x,v) -> f x v) v + +let abs_min_elt v = + match v with + | [] -> None + | (v,vl)::r -> + Some (List.fold_left (fun (v1,vl1) (v2,vl2) -> + if abs_num vl1 </ abs_num vl2 + then (v1,vl1) else (v2,vl2) ) (v,vl) r) + + +let partition p = List.partition (fun (vr,vl) -> p vr vl) + +let mkvar x = set x (Int 1) null diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index da6b1e8e9b..4c9b140aad 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -40,6 +40,9 @@ 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 +(** [pp_smt o v] prints the representation of the vector [v] over the channel [o] using SMTLIB conventions *) +val pp_smt : out_channel -> t -> unit + (** [variables v] returns the set of variables with non-zero coefficients *) val variables : t -> ISet.t @@ -49,6 +52,11 @@ val get_cst : t -> num (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) val decomp_cst : t -> num * t +(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) +val decomp_at : int -> t -> num * t + +val decomp_fst : t -> (var * num) * t + (** [cst c] returns the vector v=c+0.x1+...+0.xn *) val cst : num -> t @@ -70,10 +78,13 @@ val get : var -> t -> num i.e. the coefficient of the variable xi is set to ai' *) val set : var -> num -> t -> t +(** [mkvar xi] returns 1.xi *) +val mkvar : var -> 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) *) +(** [fresh v] return the fresh variable with index 1+ max (variables v) *) val fresh : t -> int (** [choose v] decomposes a vector [v] depending on whether it is [null] or not. @@ -154,3 +165,9 @@ 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 + +val map : (var -> num -> 'a) -> t -> 'a list + +val abs_min_elt : t -> (var * num) option + +val partition : (var -> num -> bool) -> t -> t * t diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 4802608fda..ffc3506a1f 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -535,7 +535,7 @@ let focused_simpl path = let open Tacmach.New in Proofview.Goal.enter begin fun gl -> let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in - convert_concl_no_check newc DEFAULTcast + convert_concl ~check:false newc DEFAULTcast end let focused_simpl path = focused_simpl path @@ -687,7 +687,7 @@ let simpl_coeffs path_init path_k = let n = Pervasives.(-) (List.length path_k) (List.length path_init) in let newc = context sigma (fun _ t -> loop n t) (List.rev path_init) (pf_concl gl) in - convert_concl_no_check newc DEFAULTcast + convert_concl ~check:false newc DEFAULTcast end let rec shuffle p (t1,t2) = @@ -1849,12 +1849,12 @@ let destructure_hyps = match destructurate_type env sigma typ with | Kapp(Nat,_) -> (tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index f5d13053b1..ad2ee821b3 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -54,10 +54,10 @@ Record almost_field_theory : Prop := mk_afield { Section AlmostField. Variable AFth : almost_field_theory. -Let ARth := AFth.(AF_AR). -Let rI_neq_rO := AFth.(AF_1_neq_0). -Let rdiv_def := AFth.(AFdiv_def). -Let rinv_l := AFth.(AFinv_l). +Let ARth := (AF_AR AFth). +Let rI_neq_rO := (AF_1_neq_0 AFth). +Let rdiv_def := (AFdiv_def AFth). +Let rinv_l := (AFinv_l AFth). Add Morphism radd with signature (req ==> req ==> req) as radd_ext. Proof. exact (Radd_ext Reqe). Qed. @@ -115,12 +115,12 @@ Notation "- x" := (copp x) : C_scope. Infix "=?" := ceqb : C_scope. Notation "[ x ]" := (phi x) (at level 0). -Let phi_0 := CRmorph.(morph0). -Let phi_1 := CRmorph.(morph1). +Let phi_0 := (morph0 CRmorph). +Let phi_1 := (morph1 CRmorph). Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef. Proof. -generalize (CRmorph.(morph_eq) c c'). +generalize ((morph_eq CRmorph) c c'). destruct (c =? c')%coef; auto. Qed. @@ -137,7 +137,7 @@ Variable get_sign_spec : sign_theory copp ceqb get_sign. Variable cdiv:C -> C -> C*C. Variable cdiv_th : div_theory req cadd cmul phi cdiv. -Let rpow_pow := pow_th.(rpow_pow_N). +Let rpow_pow := (rpow_pow_N pow_th). (* Polynomial expressions : (PExpr C) *) @@ -428,7 +428,7 @@ Qed. Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p]. Proof. -induction p;simpl;trivial; now rewrite !CRmorph.(morph_mul), !IHp. +induction p;simpl;trivial; now rewrite !(morph_mul CRmorph), !IHp. Qed. Lemma pow_pos_mul_l x y p : @@ -1235,12 +1235,19 @@ Notation ring_correct := (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). (* simplify a field expression into a fraction *) -(* TODO: simplify when den is constant... *) Definition display_linear l num den := - NPphi_dev l num / NPphi_dev l den. + let lnum := NPphi_dev l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_dev l den + | _ => lnum / NPphi_dev l den + end. Definition display_pow_linear l num den := - NPphi_pow l num / NPphi_pow l den. + let lnum := NPphi_pow l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_pow l den + | _ => lnum / NPphi_pow l den + end. Theorem Field_rw_correct n lpe l : Ninterp_PElist l lpe -> @@ -1252,7 +1259,18 @@ Theorem Field_rw_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_linear; apply rdiv_ext; + unfold display_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_dev _ _). + apply eq_trans with (nnum / NPphi_dev l (Pc c)). + apply rdiv_ext; + eapply ring_rw_correct; eauto. + rewrite Pphi_dev_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; eapply ring_rw_correct; eauto. Qed. @@ -1266,8 +1284,19 @@ Theorem Field_rw_pow_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear; apply rdiv_ext; - eapply ring_rw_pow_correct;eauto. + unfold display_pow_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_pow_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_pow _ _). + apply eq_trans with (nnum / NPphi_pow l (Pc c)). + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. + rewrite Pphi_pow_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. Qed. Theorem Field_correct n l lpe fe1 fe2 : @@ -1587,7 +1616,7 @@ Section FieldAndSemiField. Definition F2AF f := mk_afield - (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). + (Rth_ARth Rsth Reqe (F_R f)) (F_1_neq_0 f) (Fdiv_def f) (Finv_l f). Record semi_field_theory : Prop := mk_sfield { SF_SR : semi_ring_theory rO rI radd rmul req; @@ -1603,10 +1632,10 @@ End MakeFieldPol. Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := mk_afield _ _ - (SRth_ARth Rsth sf.(SF_SR)) - sf.(SF_1_neq_0) - sf.(SFdiv_def) - sf.(SFinv_l). + (SRth_ARth Rsth (SF_SR sf)) + (SF_1_neq_0 sf) + (SFdiv_def sf) + (SFinv_l sf). Section Complete. @@ -1621,9 +1650,9 @@ Section Complete. Notation "x == y" := (req x y) (at level 70, no associativity). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid3. Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd with signature (req ==> req ==> req) as radd_ext3. @@ -1636,10 +1665,10 @@ Section Complete. Section AlmostField. Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let ARth := AFth.(AF_AR). - Let rI_neq_rO := AFth.(AF_1_neq_0). - Let rdiv_def := AFth.(AFdiv_def). - Let rinv_l := AFth.(AFinv_l). + Let ARth := (AF_AR AFth). + Let rI_neq_rO := (AF_1_neq_0 AFth). + Let rdiv_def := (AFdiv_def AFth). + Let rinv_l := (AFinv_l AFth). Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. @@ -1705,10 +1734,10 @@ End AlmostField. Section Field. Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let Rth := Fth.(F_R). - Let rI_neq_rO := Fth.(F_1_neq_0). - Let rdiv_def := Fth.(Fdiv_def). - Let rinv_l := Fth.(Finv_l). + Let Rth := (F_R Fth). + Let rI_neq_rO := (F_1_neq_0 Fth). + Let rdiv_def := (Fdiv_def Fth). + Let rinv_l := (Finv_l Fth). Let AFth := F2AF Rsth Reqe Fth. Let ARth := Rth_ARth Rsth Reqe Rth. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 15d490a6ab..4886c8b9aa 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -51,9 +51,9 @@ Section ZMORPHISM. Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid3. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. @@ -267,9 +267,9 @@ Section NMORPHISM. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. @@ -392,9 +392,9 @@ Section NWORDMORPHISM. Notation "x == y" := (req x y). Variable Rsth : Setoid_Theory R req. Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_setoid5. Ltac rrefl := gen_reflexivity Rsth. Variable Reqe : ring_eq_ext radd rmul ropp req. @@ -581,9 +581,9 @@ Section GEN_DIV. (* Useful tactics *) Add Parametric Relation : R req - reflexivity proved by Rsth.(@Equivalence_Reflexive _ _) - symmetry proved by Rsth.(@Equivalence_Symmetric _ _) - transitivity proved by Rsth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Rsth) + symmetry proved by (@Equivalence_Symmetric _ _ Rsth) + transitivity proved by (@Equivalence_Transitive _ _ Rsth) as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd with signature (req ==> req ==> req) as radd_ext. @@ -614,7 +614,7 @@ Section GEN_DIV. Proof. constructor. intros a b;unfold triv_div. - assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). + assert (X:= morph_eq morph a b);destruct (ceqb a b). Esimpl. rewrite X; trivial. rsimpl. diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 38bc58a659..e12bf36339 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -141,6 +141,11 @@ Ltac IZR_tac t := match t with | R0 => constr:(0%Z) | R1 => constr:(1%Z) + | IZR (Z.pow_pos 10 ?p) => + match isPcst p with + | true => constr:(Z.pow_pos 10 p) + | _ => constr:(InitialRing.NotConstant) + end | IZR ?u => match isZcst u with | true => u diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 12f716c496..f7cb6b688b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -600,7 +600,7 @@ Section MakeRingPol. Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. rewrite Pos.add_comm. - apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)). Qed. Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). @@ -810,7 +810,7 @@ Section MakeRingPol. Proof. revert l. induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). + - assert (H := (div_eucl_th div_th) c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - destr_factor. Esimpl. - destr_factor. Esimpl. add_permut. @@ -827,7 +827,7 @@ Section MakeRingPol. try (case Pos.compare_spec; intros He); rewrite ?He; destr_factor; simpl; Esimpl. - - assert (H := div_th.(div_eucl_th) c0 c). + - assert (H := div_eucl_th div_th c0 c). destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. - assert (H := Mcphi_ok P c). destr_factor. Esimpl. - now rewrite <- jump_add, Pos.sub_add. @@ -1073,7 +1073,7 @@ Section POWER. - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - rewrite IHpe. Esimpl. - rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. @@ -1329,7 +1329,7 @@ Section POWER. case_eq (get_sign c);intros. assert (H1 := (morph_eq CRmorph) c0 cI). destruct (c0 ?=! cI). - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. + rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H)). Esimpl. rewrite H1;trivial. rewrite <- r_list_pow_rev;trivial;Esimpl. apply mkmultm1_ok. rewrite <- r_list_pow_rev; apply mkmult_rec_ok. @@ -1340,7 +1340,7 @@ Qed. Proof. intros;unfold mkadd_mult. case_eq (get_sign c);intros. - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. + rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H));Esimpl. rewrite mkmult_c_pos_ok;Esimpl. rewrite mkmult_c_pos_ok;Esimpl. Qed. @@ -1421,7 +1421,7 @@ Qed. | xO _ => rpow r (Cp_phi (Npos p)) | 1 => r end == pow_pos rmul r p. - Proof. destruct p; now rewrite ?pow_th.(rpow_pow_N). Qed. + Proof. destruct p; now rewrite ?(rpow_pow_N pow_th). Qed. Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 6c782269ab..3e835f5c9f 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -358,7 +358,7 @@ Section ALMOST_RING. rewrite <-(Radd_0_l Rth (- x * y)). rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). - rewrite (Rth.(Radd_comm) (-x)), (Ropp_def Rth). + rewrite (Radd_comm Rth (-x)), (Ropp_def Rth). now rewrite Rmul_0_l, (Radd_0_l Rth). Qed. @@ -407,9 +407,9 @@ Section ALMOST_RING. Variable Ceqe : ring_eq_ext cadd cmul copp ceq. Add Parametric Relation : C ceq - reflexivity proved by Csth.(@Equivalence_Reflexive _ _) - symmetry proved by Csth.(@Equivalence_Symmetric _ _) - transitivity proved by Csth.(@Equivalence_Transitive _ _) + reflexivity proved by (@Equivalence_Reflexive _ _ Csth) + symmetry proved by (@Equivalence_Symmetric _ _ Csth) + transitivity proved by (@Equivalence_Transitive _ _ Csth) as C_setoid. Add Morphism cadd with signature (ceq ==> ceq ==> ceq) as cadd_ext. @@ -430,7 +430,7 @@ Section ALMOST_RING. Lemma Smorph_opp x : [-!x] == -[x]. Proof. - rewrite <- (Rth.(Radd_0_l) [-!x]). + rewrite <- (Radd_0_l Rth [-!x]). rewrite <- ((Ropp_def Rth) [x]). rewrite ((Radd_comm Rth) [x]). rewrite <- (Radd_assoc Rth). @@ -498,12 +498,12 @@ Qed. Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. Proof. - mrewrite. now rewrite !(ARth.(ARmul_comm) z). + mrewrite. now rewrite !(ARmul_comm ARth z). Qed. Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. Proof. - now rewrite <-(ARth.(ARadd_assoc) x), (ARth.(ARadd_comm) x). + now rewrite <-(ARadd_assoc ARth x), (ARadd_comm ARth x). Qed. Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 3f69701bd3..b02b97f656 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -89,10 +89,10 @@ let protect_red map env sigma c0 = EConstr.of_constr (eval 0 c) let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) None let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) (****************************************************************************) diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index d6b7371647..49d729bd6c 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -94,20 +94,31 @@ Require Import ssreflect ssrfun. like terms from boolean equalities (can fail). This file provides a theory of boolean predicates and relations: pred T == the type of bool predicates (:= T -> bool). - simpl_pred T == the type of simplifying bool predicates, using - the simpl_fun from ssrfun.v. + simpl_pred T == the type of simplifying bool predicates, based on + the simpl_fun type from ssrfun.v. + mem_pred T == a specialized form of simpl_pred for "collective" + predicates (see below). rel T == the type of bool relations. := T -> pred T or T -> T -> bool. simpl_rel T == type of simplifying relations. + := T -> simpl_pred T predType == the generic predicate interface, supported for for lists and sets. - pred_class == a coercion class for the predType projection to - pred; declaring a coercion to pred_class is an - alternative way of equipping a type with a - predType structure, which interoperates better - with coercion subtyping. This is used, e.g., - for finite sets, so that finite groups inherit - the membership operation by coercing to sets. + pred_sort == the predType >-> Type projection; pred_sort is + itself a Coercion target class. Declaring a + coercion to pred_sort is an alternative way of + equiping a type with a predType structure, which + interoperates better with coercion subtyping. + This is used, e.g., for finite sets, so that finite + groups inherit the membership operation by + coercing to sets. + {pred T} == a type convertible to pred T, but whose head + constant is pred_sort. This type should be used + for parameters that can be used as collective + predicates (see below), as this will allow passing + in directly collections that implement predType + by coercion as described above, e.g., finite sets. + := pred_sort (predPredType T) If P is a predicate the proposition "x satisfies P" can be written applicatively as (P x), or using an explicit connective as (x \in P); in the latter case we say that P is a "collective" predicate. We use A, B @@ -119,8 +130,14 @@ Require Import ssreflect ssrfun. pred T value of one type needs to be passed as the other the following conversions should be used explicitly: SimplPred P == a (simplifying) applicative equivalent of P. - mem A == an applicative equivalent of A: - mem A x simplifies to x \in A. + mem A == an applicative equivalent of collective predicate A: + mem A x simplifies to x \in A, as mem A has in + fact type mem_pred T. + --> In user notation collective predicates _only_ occur as arguments to mem: + A only appears as (mem A). This is hidden by notation, e.g., + x \in A := in_mem x (mem A) here, enum A := enum_mem (mem A) in fintype. + This makes it possible to unify the various ways in which A can be + interpreted as a predicate, for both pattern matching and display. Alternatively one can use the syntax for explicit simplifying predicates and relations (in the following x is bound in E): #[#pred x | E#]# == simplifying (see ssrfun) predicate x => E. @@ -135,11 +152,11 @@ Require Import ssreflect ssrfun. #[#predD A & B#]# == difference of collective predicates A and B. #[#predC A#]# == complement of the collective predicate A. #[#preim f of A#]# == preimage under f of the collective predicate A. - predU P Q, ... == union, etc of applicative predicates. - pred0 == the empty predicate. - predT == the total (always true) predicate. - if T : predArgType, then T coerces to predT. - {: T} == T cast to predArgType (e.g., {: bool * nat}) + predU P Q, ..., preim f P == union, etc of applicative predicates. + pred0 == the empty predicate. + predT == the total (always true) predicate. + if T : predArgType, then T coerces to predT. + {: T} == T cast to predArgType (e.g., {: bool * nat}). In the following, x and y are bound in E: #[#rel x y | E#]# == simplifying relation x, y => E. #[#rel x y : T | E#]# == simplifying relation with arguments cast. @@ -147,7 +164,9 @@ Require Import ssreflect ssrfun. #[#rel x y in A & B#]# == #[#rel x y | (x \in A) && (y \in B) #]#. #[#rel x y in A | E#]# == #[#rel x y in A & A | E#]#. #[#rel x y in A#]# == #[#rel x y in A & A#]#. - relU R S == union of relations R and S. + relU R S == union of relations R and S. + relpre f R == preimage of relation R under f. + xpredU, ..., xrelpre == lambda terms implementing predU, ..., etc. Explicit values of type pred T (i.e., lamdba terms) should always be used applicatively, while values of collection types implementing the predType interface, such as sequences or sets should always be used as collective @@ -177,7 +196,7 @@ Require Import ssreflect ssrfun. applicative and collective styles. Purely for aesthetics, we provide a subtype of collective predicates: qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T - coerces to pred_class and thus behaves as a collective + coerces to pred_sort and thus behaves as a collective predicate, but x \in A and x \notin A are displayed as: x \is A and x \isn't A when q = 0, x \is a A and x \isn't a A when q = 1, @@ -189,11 +208,11 @@ Require Import ssreflect ssrfun. We provide an internal interface to support attaching properties (such as being multiplicative) to predicates: pred_key p == phantom type that will serve as a support for properties - to be attached to p : pred_class; instances should be + to be attached to p : {pred _}; instances should be created with Fact/Qed so as to be opaque. KeyedPred k_p == an instance of the interface structure that attaches (k_p : pred_key P) to P; the structure projection is a - coercion to pred_class. + coercion to pred_sort. KeyedQualifier k_q == an instance of the interface structure that attaches (k_q : pred_key q) to (q : qualifier n T). DefaultPredKey p == a default value for pred_key p; the vernacular command @@ -235,17 +254,20 @@ Require Import ssreflect ssrfun. {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. {in A1 & A2 & A3, Q3} <-> forall x y z, x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. - {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. - {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. - {in A &&, Q3} == {in A & A & A, Q3}. - {in A, bijective f} == f has a right inverse in A. - {on C, P1} == forall x, (f x) \in C -> Qx - when P1 is also convertible to Pf f. + {in A1 & A2 &, Q3} := {in A1 & A2 & A2, Q3}. + {in A1 && A3, Q3} := {in A1 & A1 & A3, Q3}. + {in A &&, Q3} := {in A & A & A, Q3}. + {in A, bijective f} <-> f has a right inverse in A. + {on C, P1} <-> forall x, (f x) \in C -> Qx + when P1 is also convertible to Pf f, e.g., + {on C, involutive f}. {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy - when P2 is also convertible to Pf f. + when P2 is also convertible to Pf f, e.g., + {on C &, injective f}. {on C, P1' & g} == forall x, (f x) \in cd -> Qx when P1' is convertible to Pf f - and P1' g is convertible to forall x, Qx. + and P1' g is convertible to forall x, Qx, e.g., + {on C, cancel f & g}. {on C, bijective f} == f has a right inverse on C. This file extends the lemma name suffix conventions of ssrfun as follows: A -- associativity, as in andbA : associative andb. @@ -282,13 +304,119 @@ Notation ReflectF := Bool.ReflectF. Reserved Notation "~~ b" (at level 35, right associativity). Reserved Notation "b ==> c" (at level 55, right associativity). -Reserved Notation "b1 (+) b2" (at level 50, left associativity). -Reserved Notation "x \in A" - (at level 70, format "'[hv' x '/ ' \in A ']'", no associativity). -Reserved Notation "x \notin A" - (at level 70, format "'[hv' x '/ ' \notin A ']'", no associativity). -Reserved Notation "p1 =i p2" - (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). +Reserved Notation "b1 (+) b2" (at level 50, left associativity). + +Reserved Notation "x \in A" (at level 70, no associativity, + format "'[hv' x '/ ' \in A ']'"). +Reserved Notation "x \notin A" (at level 70, no associativity, + format "'[hv' x '/ ' \notin A ']'"). +Reserved Notation "x \is A" (at level 70, no associativity, + format "'[hv' x '/ ' \is A ']'"). +Reserved Notation "x \isn't A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't A ']'"). +Reserved Notation "x \is 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'a' A ']'"). +Reserved Notation "x \isn't 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'a' A ']'"). +Reserved Notation "x \is 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'an' A ']'"). +Reserved Notation "x \isn't 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'an' A ']'"). +Reserved Notation "p1 =i p2" (at level 70, no associativity, + format "'[hv' p1 '/ ' =i p2 ']'"). +Reserved Notation "{ 'subset' A <= B }" (at level 0, A, B at level 69, + format "'[hv' { 'subset' A '/ ' <= B } ']'"). + +Reserved Notation "{ : T }" (at level 0, format "{ : T }"). +Reserved Notation "{ 'pred' T }" (at level 0, format "{ 'pred' T }"). +Reserved Notation "[ 'predType' 'of' T ]" (at level 0, + format "[ 'predType' 'of' T ]"). + +Reserved Notation "[ 'pred' : T | E ]" (at level 0, + format "'[hv' [ 'pred' : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E1 & '/ ' E2 ] ']'"). +Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E1 & E2 ] ']'"). +Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E1 & '/ ' E2 ] ']'"). + +Reserved Notation "[ 'qualify' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x : T | '/ ' P ] ']'"). + +Reserved Notation "[ 'rel' x y | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y : T | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A ] ']'"). + +Reserved Notation "[ 'mem' A ]" (at level 0, format "[ 'mem' A ]"). +Reserved Notation "[ 'predI' A & B ]" (at level 0, + format "[ 'predI' A & B ]"). +Reserved Notation "[ 'predU' A & B ]" (at level 0, + format "[ 'predU' A & B ]"). +Reserved Notation "[ 'predD' A & B ]" (at level 0, + format "[ 'predD' A & B ]"). +Reserved Notation "[ 'predC' A ]" (at level 0, + format "[ 'predC' A ]"). +Reserved Notation "[ 'preim' f 'of' A ]" (at level 0, + format "[ 'preim' f 'of' A ]"). + +Reserved Notation "\unless C , P" (at level 200, C at level 100, + format "'[hv' \unless C , '/ ' P ']'"). + +Reserved Notation "{ 'for' x , P }" (at level 0, + format "'[hv' { 'for' x , '/ ' P } ']'"). +Reserved Notation "{ 'in' d , P }" (at level 0, + format "'[hv' { 'in' d , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & , P }" (at level 0, + format "'[hv' { 'in' d & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & & , P }" (at level 0, + format "'[hv' { 'in' d & & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P }" (at level 0, + format "'[hv' { 'on' cd , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd & , P }" (at level 0, + format "'[hv' { 'on' cd & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P & g }" (at level 0, g at level 8, + format "'[hv' { 'on' cd , '/ ' P & g } ']'"). +Reserved Notation "{ 'in' d , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'in' d , '/ ' 'bijective' f } ']'"). +Reserved Notation "{ 'on' cd , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'on' cd , '/ ' 'bijective' f } ']'"). + (** We introduce a number of n-ary "list-style" notations that share a common @@ -335,18 +463,6 @@ Reserved Notation "[ ==> b1 => c ]" (at level 0, only parsing). Reserved Notation "[ ==> b1 , b2 , .. , bn => c ]" (at level 0, format "'[hv' [ ==> '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/' => c ] ']'"). -Reserved Notation "[ 'pred' : T => E ]" (at level 0, format - "'[hv' [ 'pred' : T => '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x => E ]" (at level 0, x at level 8, format - "'[hv' [ 'pred' x => '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x : T => E ]" (at level 0, x at level 8, format - "'[hv' [ 'pred' x : T => '/ ' E ] ']'"). - -Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format - "'[hv' [ 'rel' x y => '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format - "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). - (** Shorter delimiter **) Delimit Scope bool_scope with B. Open Scope bool_scope. @@ -622,9 +738,7 @@ Hint View for apply/ impliesPn|2 impliesP|2. Definition unless condition property : Prop := forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. -Notation "\unless C , P" := (unless C P) - (at level 200, C at level 100, - format "'[' \unless C , '/ ' P ']'") : type_scope. +Notation "\unless C , P" := (unless C P) : type_scope. Lemma unlessL C P : implies C (\unless C, P). Proof. by split=> hC G /(_ hC). Qed. @@ -1002,8 +1116,7 @@ Ltac bool_congr := Moreover these infix forms are convertible to their prefix counterpart (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse is not true, however; collective predicate types cannot, in general, be - general, be used applicatively, because of the "uniform inheritance" - restriction on implicit coercions. + used applicatively, because of restrictions on implicit coercions. However, we do define an explicit generic coercion - mem : forall (pT : predType), pT -> mem_pred T where mem_pred T is a variant of simpl_pred T that preserves the infix @@ -1019,319 +1132,391 @@ Ltac bool_congr := not to use it applicatively; this avoids the burden of having to declare a different predicate type for each predicate parameter of each section or lemma. - This trick is made possible by the fact that the constructor of the - mem_pred T type aligns the unification process, forcing a generic - "collective" predicate A : pred T to unify with the actual collective B, - which mem has coerced to pred T via an internal, hidden implicit coercion, - supplied by the predType structure for B. Users should take care not to - inadvertently "strip" (mem B) down to the coerced B, since this will - expose the internal coercion: Coq will display a term B x that cannot be - typed as such. The topredE lemma can be used to restore the x \in B - syntax in this case. While -topredE can conversely be used to change - x \in P into P x, it is safer to use the inE and memE lemmas instead, as - they do not run the risk of exposing internal coercions. As a consequence - it is better to explicitly cast a generic applicative pred T to simpl_pred - using the SimplPred constructor, when it is used as a collective predicate - (see, e.g., Lemma eq_big in bigop). + In detail, we ensure that the head normal form of mem A is always of the + eta-long MemPred (fun x => pA x) form, where pA is the pred interpretation of + A following its predType pT, i.e., the _expansion_ of topred A. For a pred T + evar ?P, (mem ?P) converts MemPred (fun x => ?P x), whose argument is a Miller + pattern and therefore always unify: unifying (mem A) with (mem ?P) always + yields ?P = pA, because the rigid constant MemPred aligns the unification. + Furthermore, we ensure pA is always either A or toP .... A where toP ... is + the expansion of @topred T pT, and toP is declared as a Coercion, so pA will + _display_ as A in either case, and the instances of @mem T (predPredType T) pA + appearing in the premises or right-hand side of a generic lemma parametrized + by ?P will be indistinguishable from @mem T pT A. + Users should take care not to inadvertently "strip" (mem A) down to the + coerced A, since this will expose the internal toP coercion: Coq could then + display terms A x that cannot be typed as such. The topredE lemma can be used + to restore the x \in A syntax in this case. While -topredE can conversely be + used to change x \in P into P x for an applicative P, it is safer to use the + inE, unfold_in or and memE lemmas instead, as they do not run the risk of + exposing internal coercions. As a consequence it is better to explicitly + cast a generic applicative predicate to simpl_pred using the SimplPred + constructor when it is used as a collective predicate (see, e.g., + Lemma eq_big in bigop). We also sometimes "instantiate" the predType structure by defining a - coercion to the sort of the predPredType structure. This works better for - types such as {set T} that have subtypes that coerce to them, since the - same coercion will be inserted by the application of mem. It also lets us - turn any Type aT : predArgType into the total predicate over that type, - i.e., fun _: aT => true. This allows us to write, e.g., ##|'I_n| for the - cardinal of the (finite) type of integers less than n. - Collective predicates have a specific extensional equality, - - A =i B, - while applicative predicates use the extensional equality of functions, - - P =1 Q - The two forms are convertible, however. - We lift boolean operations to predicates, defining: - - predU (union), predI (intersection), predC (complement), - predD (difference), and preim (preimage, i.e., composition) - For each operation we define three forms, typically: - - predU : pred T -> pred T -> simpl_pred T - - #[#predU A & B#]#, a Notation for predU (mem A) (mem B) - - xpredU, a Notation for the lambda-expression inside predU, - which is mostly useful as an argument of =1, since it exposes the head - head constant of the expression to the ssreflect matching algorithm. - The syntax for the preimage of a collective predicate A is - - #[#preim f of A#]# - Finally, the generic syntax for defining a simpl_pred T is - - #[#pred x : T | P(x) #]#, #[#pred x | P(x) #]#, #[#pred x in A | P(x) #]#, etc. - We also support boolean relations, but only the applicative form, with - types - - rel T, an alias for T -> pred T - - simpl_rel T, an auto-simplifying version, and syntax - #[#rel x y | P(x,y) #]#, #[#rel x y in A & B | P(x,y) #]#, etc. - The notation #[#rel of fA#]# can be used to coerce a function returning a - collective predicate to one returning pred T. - Finally, note that there is specific support for ambivalent predicates - that can work in either style, as per this file's head descriptor. **) - + coercion to the sort of the predPredType structure, conveniently denoted + {pred T}. This works better for types such as {set T} that have subtypes that + coerce to them, since the same coercion will be inserted by the application + of mem, or of any lemma that expects a generic collective predicates with + type {pred T} := pred_sort (predPredType T) = pred T; thus {pred T} should be + the preferred type for generic collective predicate parameters. + This device also lets us turn any Type aT : predArgType into the total + predicate over that type, i.e., fun _: aT => true. This allows us to write, + e.g., ##|'I_n| for the cardinal of the (finite) type of integers less than n. + **) + +(** Boolean predicates. *) Definition pred T := T -> bool. - Identity Coercion fun_of_pred : pred >-> Funclass. -Definition rel T := T -> pred T. +Definition subpred T (p1 p2 : pred T) := forall x : T, p1 x -> p2 x. -Identity Coercion fun_of_rel : rel >-> Funclass. +(* Notation for some manifest predicates. *) -Notation xpred0 := (fun _ => false). -Notation xpredT := (fun _ => true). +Notation xpred0 := (fun=> false). +Notation xpredT := (fun=> true). Notation xpredI := (fun (p1 p2 : pred _) x => p1 x && p2 x). Notation xpredU := (fun (p1 p2 : pred _) x => p1 x || p2 x). Notation xpredC := (fun (p : pred _) x => ~~ p x). Notation xpredD := (fun (p1 p2 : pred _) x => ~~ p2 x && p1 x). Notation xpreim := (fun f (p : pred _) x => p (f x)). -Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). -Section Predicates. +(** The packed class interface for pred-like types. **) -Variables T : Type. - -Definition subpred (p1 p2 : pred T) := forall x, p1 x -> p2 x. - -Definition subrel (r1 r2 : rel T) := forall x y, r1 x y -> r2 x y. - -Definition simpl_pred := simpl_fun T bool. -Definition applicative_pred := pred T. -Definition collective_pred := pred T. +#[universes(template)] +Structure predType T := + PredType {pred_sort :> Type; topred : pred_sort -> pred T}. + +Definition clone_pred T U := + fun pT & @pred_sort T pT -> U => + fun toP (pT' := @PredType T U toP) & phant_id pT' pT => pT'. +Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ id) : form_scope. + +Canonical predPredType T := PredType (@id (pred T)). +Canonical boolfunPredType T := PredType (@id (T -> bool)). + +(** The type of abstract collective predicates. + While {pred T} is contertible to pred T, it presents the pred_sort coercion + class, which crucially does _not_ coerce to Funclass. Term whose type P coerces + to {pred T} cannot be applied to arguments, but they _can_ be used as if P + had a canonical predType instance, as the coercion will be inserted if the + unification P =~= pred_sort ?pT fails, changing the problem into the trivial + {pred T} =~= pred_sort ?pT (solution ?pT := predPredType P). + Additional benefits of this approach are that any type coercing to P will + also inherit this behaviour, and that the coercion will be apparent in the + elaborated expression. The latter may be important if the coercion is also + a canonical structure projector - see mathcomp/fingroup/fingroup.v. The + main drawback of implementing predType by coercion in this way is that the + type of the value must be known when the unification constraint is imposed: + if we only register the constraint and then later discover later that the + expression had type P it will be too late of insert a coercion, whereas a + canonical instance of predType fo P would have solved the deferred constraint. + Finally, definitions, lemmas and sections should use type {pred T} for + their generic collective type parameters, as this will make it possible to + apply such definitions and lemmas directly to values of types that implement + predType by coercion to {pred T} (values of types that implement predType + without coercing to {pred T} will have to be coerced explicitly using topred). +**) +Notation "{ 'pred' T }" := (pred_sort (predPredType T)) : type_scope. + +(** The type of self-simplifying collective predicates. **) +Definition simpl_pred T := simpl_fun T bool. +Definition SimplPred {T} (p : pred T) : simpl_pred T := SimplFun p. + +(** Some simpl_pred constructors. **) + +Definition pred0 {T} := @SimplPred T xpred0. +Definition predT {T} := @SimplPred T xpredT. +Definition predI {T} (p1 p2 : pred T) := SimplPred (xpredI p1 p2). +Definition predU {T} (p1 p2 : pred T) := SimplPred (xpredU p1 p2). +Definition predC {T} (p : pred T) := SimplPred (xpredC p). +Definition predD {T} (p1 p2 : pred T) := SimplPred (xpredD p1 p2). +Definition preim {aT rT} (f : aT -> rT) (d : pred rT) := SimplPred (xpreim f d). + +Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) : fun_scope. +Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) : fun_scope. +Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] : fun_scope. +Notation "[ 'pred' x : T | E ]" := + (SimplPred (fun x : T => E%B)) (only parsing) : fun_scope. +Notation "[ 'pred' x : T | E1 & E2 ]" := + [pred x : T | E1 && E2 ] (only parsing) : fun_scope. + +(** Coercions for simpl_pred. + As simpl_pred T values are used both applicatively and collectively we + need simpl_pred to coerce to both pred T _and_ {pred T}. However it is + undesireable to have two distinct constants for what are essentially identical + coercion functions, as this confuses the SSReflect keyed matching algorithm. + While the Coq Coercion declarations appear to disallow such Coercion aliasing, + it is possible to work around this limitation with a combination of modules + and functors, which we do below. + In addition we also give a predType instance for simpl_pred, which will + be preferred to the {pred T} coercion to solve simpl_pred T =~= pred_sort ?pT + constraints; not however that the pred_of_simpl coercion _will_ be used + when a simpl_pred T is passed as a {pred T}, since the simplPredType T + structure for simpl_pred T is _not_ convertible to predPredType T. **) + +Module PredOfSimpl. +Definition coerce T (sp : simpl_pred T) : pred T := fun_of_simpl sp. +End PredOfSimpl. +Notation pred_of_simpl := PredOfSimpl.coerce. +Coercion pred_of_simpl : simpl_pred >-> pred. +Canonical simplPredType T := PredType (@pred_of_simpl T). + +Module Type PredSortOfSimplSignature. +Parameter coerce : forall T, simpl_pred T -> {pred T}. +End PredSortOfSimplSignature. +Module DeclarePredSortOfSimpl (PredSortOfSimpl : PredSortOfSimplSignature). +Coercion PredSortOfSimpl.coerce : simpl_pred >-> pred_sort. +End DeclarePredSortOfSimpl. +Module Export PredSortOfSimplCoercion := DeclarePredSortOfSimpl PredOfSimpl. + +(** Type to pred coercion. + This lets us use types of sort predArgType as a synonym for their universal + predicate. We define this predicate as a simpl_pred T rather than a pred T or + a {pred T} so that /= and inE reduce (T x) and x \in T to true, respectively. + Unfortunately, this can't be used for existing types like bool whose sort + is already fixed (at least, not without redefining bool, true, false and + all bool operations and lemmas); we provide syntax to recast a given type + in predArgType as a workaround. **) +Definition predArgType := Type. +Bind Scope type_scope with predArgType. +Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. +Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. +Notation "{ : T }" := (T%type : predArgType) : type_scope. -Definition SimplPred (p : pred T) : simpl_pred := SimplFun p. +(** Boolean relations. + Simplifying relations follow the coding pattern of 2-argument simplifying + functions: the simplifying type constructor is applied to the _last_ + argument. This design choice will let the in_simpl componenent of inE expand + membership in simpl_rel as well. We provide an explicit coercion to rel T + to avoid eta-expansion during coercion; this coercion self-simplifies so it + should be invisible. + **) -Coercion pred_of_simpl (p : simpl_pred) : pred T := fun_of_simpl p. -Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := - fun_of_simpl p. -Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := - fun x => (let: SimplFun f := p in fun _ => f x) x. -(** - Note: applicative_of_simpl is convertible to pred_of_simpl, while - collective_of_simpl is not. **) +Definition rel T := T -> pred T. +Identity Coercion fun_of_rel : rel >-> Funclass. -Definition pred0 := SimplPred xpred0. -Definition predT := SimplPred xpredT. -Definition predI p1 p2 := SimplPred (xpredI p1 p2). -Definition predU p1 p2 := SimplPred (xpredU p1 p2). -Definition predC p := SimplPred (xpredC p). -Definition predD p1 p2 := SimplPred (xpredD p1 p2). -Definition preim rT f (d : pred rT) := SimplPred (xpreim f d). +Definition subrel T (r1 r2 : rel T) := forall x y : T, r1 x y -> r2 x y. -Definition simpl_rel := simpl_fun T (pred T). +Definition simpl_rel T := T -> simpl_pred T. -Definition SimplRel (r : rel T) : simpl_rel := [fun x => r x]. +Coercion rel_of_simpl T (sr : simpl_rel T) : rel T := fun x : T => sr x. +Arguments rel_of_simpl {T} sr x /. -Coercion rel_of_simpl_rel (r : simpl_rel) : rel T := fun x y => r x y. +Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). +Notation xrelpre := (fun f (r : rel _) x y => r (f x) (f y)). -Definition relU r1 r2 := SimplRel (xrelU r1 r2). +Definition SimplRel {T} (r : rel T) : simpl_rel T := fun x => SimplPred (r x). +Definition relU {T} (r1 r2 : rel T) := SimplRel (xrelU r1 r2). +Definition relpre {aT rT} (f : aT -> rT) (r : rel rT) := SimplRel (xrelpre f r). -Lemma subrelUl r1 r2 : subrel r1 (relU r1 r2). -Proof. by move=> *; apply/orP; left. Qed. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) : fun_scope. +Notation "[ 'rel' x y : T | E ]" := + (SimplRel (fun x y : T => E%B)) (only parsing) : fun_scope. -Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). -Proof. by move=> *; apply/orP; right. Qed. +Lemma subrelUl T (r1 r2 : rel T) : subrel r1 (relU r1 r2). +Proof. by move=> x y r1xy; apply/orP; left. Qed. -#[universes(template)] -Variant mem_pred := Mem of pred T. +Lemma subrelUr T (r1 r2 : rel T) : subrel r2 (relU r1 r2). +Proof. by move=> x y r2xy; apply/orP; right. Qed. -Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). +(** Variant of simpl_pred specialised to the membership operator. **) #[universes(template)] -Structure predType := PredType { - pred_sort :> Type; - topred : pred_sort -> pred T; - _ : {mem | isMem topred mem} -}. - -Definition mkPredType pT toP := PredType (exist (@isMem pT toP) _ (erefl _)). - -Canonical predPredType := Eval hnf in @mkPredType (pred T) id. -Canonical simplPredType := Eval hnf in mkPredType pred_of_simpl. -Canonical boolfunPredType := Eval hnf in @mkPredType (T -> bool) id. - -Coercion pred_of_mem mp : pred_sort predPredType := let: Mem p := mp in [eta p]. -Canonical memPredType := Eval hnf in mkPredType pred_of_mem. - -Definition clone_pred U := - fun pT & pred_sort pT -> U => - fun a mP (pT' := @PredType U a mP) & phant_id pT' pT => pT'. - -End Predicates. - -Arguments pred0 {T}. -Arguments predT {T}. -Prenex Implicits pred0 predT predI predU predC predD preim relU. - -Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) - (at level 0, format "[ 'pred' : T | E ]") : fun_scope. -Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) - (at level 0, x ident, format "[ 'pred' x | E ]") : fun_scope. -Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] - (at level 0, x ident, format "[ 'pred' x | E1 & E2 ]") : fun_scope. -Notation "[ 'pred' x : T | E ]" := (SimplPred (fun x : T => E%B)) - (at level 0, x ident, only parsing) : fun_scope. -Notation "[ 'pred' x : T | E1 & E2 ]" := [pred x : T | E1 && E2 ] - (at level 0, x ident, only parsing) : fun_scope. -Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) - (at level 0, x ident, y ident, format "[ 'rel' x y | E ]") : fun_scope. -Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) - (at level 0, x ident, y ident, only parsing) : fun_scope. - -Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) - (at level 0, format "[ 'predType' 'of' T ]") : form_scope. +Variant mem_pred T := Mem of pred T. (** - This redundant coercion lets us "inherit" the simpl_predType canonical - instance by declaring a coercion to simpl_pred. This hack is the only way - to put a predType structure on a predArgType. We use simpl_pred rather - than pred to ensure that /= removes the identity coercion. Note that the - coercion will never be used directly for simpl_pred, since the canonical - instance should always be resolved. **) - -Notation pred_class := (pred_sort (predPredType _)). -Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. + We mainly declare pred_of_mem as a coercion so that it is not displayed. + Similarly to pred_of_simpl, it will usually not be inserted by type + inference, as all mem_pred mp =~= pred_sort ?pT unification problems will + be solve by the memPredType instance below; pred_of_mem will however + be used if a mem_pred T is used as a {pred T}, which is desireable as it + will avoid a redundant mem in a collective, e.g., passing (mem A) to a lemma + expection a generic collective predicate p : {pred T} and premise x \in P + will display a subgoal x \in A rathere than x \in mem A. + Conversely, pred_of_mem will _not_ if it is used id (mem A) is used + applicatively or as a pred T; there the simpl_of_mem coercion defined below + will be used, resulting in a subgoal that displays as mem A x by simplifies + to x \in A. + **) +Coercion pred_of_mem {T} mp : {pred T} := let: Mem p := mp in [eta p]. +Canonical memPredType T := PredType (@pred_of_mem T). + +Definition in_mem {T} (x : T) mp := pred_of_mem mp x. +Definition eq_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 = in_mem x mp2. +Definition sub_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 -> in_mem x mp2. + +Arguments in_mem {T} x mp : simpl never. +Typeclasses Opaque eq_mem. +Typeclasses Opaque sub_mem. -(** - This lets us use some types as a synonym for their universal predicate. - Unfortunately, this won't work for existing types like bool, unless we - redefine bool, true, false and all bool ops. **) -Definition predArgType := Type. -Bind Scope type_scope with predArgType. -Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. -Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. +(** The [simpl_of_mem; pred_of_simpl] path provides a new mem_pred >-> pred + coercion, but does _not_ override the pred_of_mem : mem_pred >-> pred_sort + explicit coercion declaration above. + **) +Coercion simpl_of_mem {T} mp := SimplPred (fun x : T => in_mem x mp). -Notation "{ : T }" := (T%type : predArgType) - (at level 0, format "{ : T }") : type_scope. +Lemma sub_refl T (mp : mem_pred T) : sub_mem mp mp. Proof. by []. Qed. +Arguments sub_refl {T mp} [x] mp_x. (** - These must be defined outside a Section because "cooking" kills the - nosimpl tag. **) - + It is essential to interlock the production of the Mem constructor inside + the branch of the predType match, to ensure that unifying mem A with + Mem [eta ?p] sets ?p := toP A (or ?p := P if toP = id and A = [eta P]), + rather than topred pT A, had we put mem A := Mem (topred A). +**) Definition mem T (pT : predType T) : pT -> mem_pred T := - nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). -Definition in_mem T x mp := nosimpl pred_of_mem T mp x. - -Prenex Implicits mem. - -Coercion pred_of_mem_pred T mp := [pred x : T | in_mem x mp]. - -Definition eq_mem T p1 p2 := forall x : T, in_mem x p1 = in_mem x p2. -Definition sub_mem T p1 p2 := forall x : T, in_mem x p1 -> in_mem x p2. - -Typeclasses Opaque eq_mem. - -Lemma sub_refl T (p : mem_pred T) : sub_mem p p. Proof. by []. Qed. -Arguments sub_refl {T p}. + let: PredType toP := pT in fun A => Mem [eta toP A]. +Arguments mem {T pT} A : rename, simpl never. Notation "x \in A" := (in_mem x (mem A)) : bool_scope. Notation "x \in A" := (in_mem x (mem A)) : bool_scope. Notation "x \notin A" := (~~ (x \in A)) : bool_scope. Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. -Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) - (at level 0, A, B at level 69, - format "{ '[hv' 'subset' A '/ ' <= B ']' }") : type_scope. -Notation "[ 'mem' A ]" := (pred_of_simpl (pred_of_mem_pred (mem A))) - (at level 0, only parsing) : fun_scope. -Notation "[ 'rel' 'of' fA ]" := (fun x => [mem (fA x)]) - (at level 0, format "[ 'rel' 'of' fA ]") : fun_scope. -Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) - (at level 0, format "[ 'predI' A & B ]") : fun_scope. -Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) - (at level 0, format "[ 'predU' A & B ]") : fun_scope. -Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) - (at level 0, format "[ 'predD' A & B ]") : fun_scope. -Notation "[ 'predC' A ]" := (predC [mem A]) - (at level 0, format "[ 'predC' A ]") : fun_scope. -Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) - (at level 0, format "[ 'preim' f 'of' A ]") : fun_scope. - -Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] - (at level 0, x ident, format "[ 'pred' x 'in' A ]") : fun_scope. -Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] - (at level 0, x ident, format "[ 'pred' x 'in' A | E ]") : fun_scope. -Notation "[ 'pred' x 'in' A | E1 & E2 ]" := [pred x | x \in A & E1 && E2 ] - (at level 0, x ident, - format "[ 'pred' x 'in' A | E1 & E2 ]") : fun_scope. +Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) : type_scope. + +Notation "[ 'mem' A ]" := + (pred_of_simpl (simpl_of_mem (mem A))) (only parsing) : fun_scope. + +Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) : fun_scope. +Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) : fun_scope. +Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) : fun_scope. +Notation "[ 'predC' A ]" := (predC [mem A]) : fun_scope. +Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) : fun_scope. +Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] : fun_scope. +Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] : fun_scope. +Notation "[ 'pred' x 'in' A | E1 & E2 ]" := + [pred x | x \in A & E1 && E2 ] : fun_scope. + Notation "[ 'rel' x y 'in' A & B | E ]" := - [rel x y | (x \in A) && (y \in B) && E] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A & B | E ]") : fun_scope. -Notation "[ 'rel' x y 'in' A & B ]" := [rel x y | (x \in A) && (y \in B)] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A & B ]") : fun_scope. -Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A | E ]") : fun_scope. -Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A ]") : fun_scope. - -Section simpl_mem. - -Variables (T : Type) (pT : predType T). -Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). + [rel x y | (x \in A) && (y \in B) && E] : fun_scope. +Notation "[ 'rel' x y 'in' A & B ]" := + [rel x y | (x \in A) && (y \in B)] : fun_scope. +Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] : fun_scope. +Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] : fun_scope. + +(** Aliases of pred T that let us tag intances of simpl_pred as applicative + or collective, via bespoke coercions. This tagging will give control over + the simplification behaviour of inE and othe rewriting lemmas below. + For this control to work it is crucial that collective_of_simpl _not_ + be convertible to either applicative_of_simpl or pred_of_simpl. Indeed + they differ here by a commutattive conversion (of the match and lambda). + **) +Definition applicative_pred T := pred T. +Definition collective_pred T := pred T. +Coercion applicative_pred_of_simpl T (sp : simpl_pred T) : applicative_pred T := + fun_of_simpl sp. +Coercion collective_pred_of_simpl T (sp : simpl_pred T) : collective_pred T := + let: SimplFun p := sp in p. + +(** Explicit simplification rules for predicate application and membership. **) +Section PredicateSimplification. + +Variables T : Type. + +Implicit Types (p : pred T) (pT : predType T) (sp : simpl_pred T). +Implicit Types (mp : mem_pred T). (** - Bespoke structures that provide fine-grained control over matching the - various forms of the \in predicate; note in particular the different forms - of hoisting that are used. We had to work around several bugs in the - implementation of unification, notably improper expansion of telescope - projections and overwriting of a variable assignment by a later - unification (probably due to conversion cache cross-talk). **) + The following four bespoke structures provide fine-grained control over + matching the various predicate forms. While all four follow a common pattern + of using a canonical projection to match a particular form of predicate + (in pred T, simpl_pred, mem_pred and mem_pred, respectively), and display + the matched predicate in the structure type, each is in fact used for a + different, specific purpose: + - registered_applicative_pred: this user-facing structure is used to + declare values of type pred T meant to be used applicatively. The + structure parameter merely displays this same value, and is used to avoid + undesireable, visible occurrence of the structure in the right hand side + of rewrite rules such as app_predE. + There is a canonical instance of registered_applicative_pred for values + of the applicative_of_simpl coercion, which handles the + Definition Apred : applicative_pred T := [pred x | ...] idiom. + This instance is mainly intended for the in_applicative component of inE, + in conjunction with manifest_mem_pred and applicative_mem_pred. + - manifest_simpl_pred: the only instance of this structure matches manifest + simpl_pred values of the form SimplPred p, displaying p in the structure + type. This structure is used in in_simpl to detect and selectively expand + collective predicates of this form. An explicit SimplPred p pattern would + _NOT_ work for this purpose, as then the left-hand side of in_simpl would + reduce to in_mem ?x (Mem [eta ?p]) and would thus match _any_ instance + of \in, not just those arising from a manifest simpl_pred. + - manifest_mem_pred: similar to manifest_simpl_pred, the one instance of this + structure matches manifest mem_pred values of the form Mem [eta ?p]. The + purpose is different however: to match and display in ?p the actual + predicate appearing in an ... \in ... expression matched by the left hand + side of the in_applicative component of inE; then + - applicative_mem_pred is a telescope refinement of manifest_mem_pred p with + a default constructor that checks that the predicate p is the value of a + registered_applicative_pred; any unfolding occurring during this check + does _not_ affect the value of p passed to in_applicative, since that + has been fixed earlier by the manifest_mem_pred match. In particular the + definition of a predicate using the applicative_pred_of_simpl idiom above + will not be expanded - this very case is the reason in_applicative uses + a mem_pred telescope in its left hand side. The more straighforward + ?x \in applicative_pred_value ?ap (equivalent to in_mem ?x (Mem ?ap)) + with ?ap : registered_applicative_pred ?p would set ?p := [pred x | ...] + rather than ?p := Apred in the example above. + Also note that the in_applicative component of inE must be come before the + in_simpl one, as the latter also matches terms of the form x \in Apred. + Finally, no component of inE matches x \in Acoll, when + Definition Acoll : collective_pred T := [pred x | ...]. + as the collective_pred_of_simpl is _not_ convertible to pred_of_simpl. **) + #[universes(template)] -Structure manifest_applicative_pred p := ManifestApplicativePred { - manifest_applicative_pred_value :> pred T; - _ : manifest_applicative_pred_value = p +Structure registered_applicative_pred p := RegisteredApplicativePred { + applicative_pred_value :> pred T; + _ : applicative_pred_value = p }. -Definition ApplicativePred p := ManifestApplicativePred (erefl p). +Definition ApplicativePred p := RegisteredApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). #[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { - manifest_simpl_pred_value :> simpl_pred T; - _ : manifest_simpl_pred_value = SimplPred p + simpl_pred_value :> simpl_pred T; + _ : simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). #[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { - manifest_mem_pred_value :> mem_pred T; - _ : manifest_mem_pred_value= Mem [eta p] + mem_pred_value :> mem_pred T; + _ : mem_pred_value = Mem [eta p] }. -Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). +Canonical expose_mem_pred p := ManifestMemPred (erefl (Mem [eta p])). #[universes(template)] Structure applicative_mem_pred p := ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. -Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := - @ApplicativeMemPred ap mp. +Canonical check_applicative_mem_pred p (ap : registered_applicative_pred p) := + [eta @ApplicativeMemPred ap]. -Lemma mem_topred (pp : pT) : mem (topred pp) = mem pp. -Proof. by rewrite /mem; case: pT pp => T1 app1 [mem1 /= ->]. Qed. +Lemma mem_topred pT (pp : pT) : mem (topred pp) = mem pp. +Proof. by case: pT pp. Qed. -Lemma topredE x (pp : pT) : topred pp x = (x \in pp). +Lemma topredE pT x (pp : pT) : topred pp x = (x \in pp). Proof. by rewrite -mem_topred. Qed. -Lemma app_predE x p (ap : manifest_applicative_pred p) : ap x = (x \in p). +Lemma app_predE x p (ap : registered_applicative_pred p) : ap x = (x \in p). Proof. by case: ap => _ /= ->. Qed. Lemma in_applicative x p (amp : applicative_mem_pred p) : in_mem x amp = p x. -Proof. by case: amp => [[_ /= ->]]. Qed. +Proof. by case: amp => -[_ /= ->]. Qed. Lemma in_collective x p (msp : manifest_simpl_pred p) : (x \in collective_pred_of_simpl msp) = p x. Proof. by case: msp => _ /= ->. Qed. Lemma in_simpl x p (msp : manifest_simpl_pred p) : - in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. + in_mem x (Mem [eta pred_of_simpl msp]) = p x. Proof. by case: msp => _ /= ->. Qed. (** Because of the explicit eta expansion in the left-hand side, this lemma - should only be used in a right-to-left direction. The 8.3 hack allowing - partial right-to-left use does not work with the improved expansion - heuristics in 8.4. **) + should only be used in the left-to-right direction. + **) Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. Proof. by []. Qed. @@ -1345,55 +1530,39 @@ Proof. by []. Qed. Definition memE := mem_simpl. (* could be extended *) -Lemma mem_mem (pp : pT) : (mem (mem pp) = mem pp) * (mem [mem pp] = mem pp). -Proof. by rewrite -mem_topred. Qed. +Lemma mem_mem mp : + (mem mp = mp) * (mem (mp : simpl_pred T) = mp) * (mem (mp : pred T) = mp). +Proof. by case: mp. Qed. -End simpl_mem. +End PredicateSimplification. (** Qualifiers and keyed predicates. **) #[universes(template)] -Variant qualifier (q : nat) T := Qualifier of predPredType T. +Variant qualifier (q : nat) T := Qualifier of {pred T}. -Coercion has_quality n T (q : qualifier n T) : pred_class := +Coercion has_quality n T (q : qualifier n T) : {pred T} := fun x => let: Qualifier _ p := q in p x. Arguments has_quality n {T}. Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. -Notation "x \is A" := (x \in has_quality 0 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is A ']'") : bool_scope. -Notation "x \is 'a' A" := (x \in has_quality 1 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is 'a' A ']'") : bool_scope. -Notation "x \is 'an' A" := (x \in has_quality 2 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is 'an' A ']'") : bool_scope. -Notation "x \isn't A" := (x \notin has_quality 0 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't A ']'") : bool_scope. -Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'a' A ']'") : bool_scope. -Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'an' A ']'") : bool_scope. -Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' x : T | P ]" := (Qualifier 0 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. -Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' 'a' x : T | P ]" := (Qualifier 1 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. -Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. +Notation "x \is A" := (x \in has_quality 0 A) : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) : bool_scope. +Notation "x \isn't A" := (x \notin has_quality 0 A) : bool_scope. +Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) : bool_scope. +Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) : bool_scope. +Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' x : T | P ]" := + (Qualifier 0 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'a' x : T | P ]" := + (Qualifier 1 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'an' x | P ]" := + (Qualifier 2 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'an' x : T | P ]" := + (Qualifier 2 (fun x : T => P%B)) (only parsing) : form_scope. (** Keyed predicates: support for property-bearing predicate interfaces. **) @@ -1401,12 +1570,12 @@ Section KeyPred. Variable T : Type. #[universes(template)] -Variant pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : {pred T}) := DefaultPredKey. -Variable p : predPredType T. +Variable p : {pred T}. #[universes(template)] Structure keyed_pred (k : pred_key p) := - PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. + PackKeyedPred {unkey_pred :> {pred T}; _ : unkey_pred =i p}. Variable k : pred_key p. Definition KeyedPred := @PackKeyedPred k p (frefl _). @@ -1418,10 +1587,10 @@ Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. Instances that strip the mem cast; the first one has "pred_of_mem" as its projection head value, while the second has "pred_of_simpl". The latter has the side benefit of preempting accidental misdeclarations. - Note: pred_of_mem is the registered mem >-> pred_class coercion, while - simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We + Note: pred_of_mem is the registered mem >-> pred_sort coercion, while + [simpl_of_mem; pred_of_simpl] is the mem >-> pred >=> Funclass coercion. We must write down the coercions explicitly as the Canonical head constant - computation does not strip casts !! **) + computation does not strip casts. **) Canonical keyed_mem := @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. Canonical keyed_mem_simpl := @@ -1429,8 +1598,8 @@ Canonical keyed_mem_simpl := End KeyPred. -Notation "x \i 'n' S" := (x \in @unkey_pred _ S _ _) - (at level 70, format "'[hv' x '/ ' \i 'n' S ']'") : bool_scope. +Local Notation in_unkey x S := (x \in @unkey_pred _ S _ _) (only parsing). +Notation "x \in S" := (in_unkey x S) (only printing) : bool_scope. Section KeyedQualifier. @@ -1447,12 +1616,12 @@ Canonical keyed_qualifier_keyed := PackKeyedPred k keyed_qualifier_suproof. End KeyedQualifier. -Notation "x \i 's' A" := (x \i n has_quality 0 A) - (at level 70, format "'[hv' x '/ ' \i 's' A ']'") : bool_scope. -Notation "x \i 's' 'a' A" := (x \i n has_quality 1 A) - (at level 70, format "'[hv' x '/ ' \i 's' 'a' A ']'") : bool_scope. -Notation "x \i 's' 'an' A" := (x \i n has_quality 2 A) - (at level 70, format "'[hv' x '/ ' \i 's' 'an' A ']'") : bool_scope. +Notation "x \is A" := + (in_unkey x (has_quality 0 A)) (only printing) : bool_scope. +Notation "x \is 'a' A" := + (in_unkey x (has_quality 1 A)) (only printing) : bool_scope. +Notation "x \is 'an' A" := + (in_unkey x (has_quality 2 A)) (only printing) : bool_scope. Module DefaultKeying. @@ -1592,7 +1761,7 @@ Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := End LocalProperties. Definition inPhantom := Phantom Prop. -Definition onPhantom T P (x : T) := Phantom Prop (P x). +Definition onPhantom {T} P (x : T) := Phantom Prop (P x). Definition bijective_in aT rT (d : mem_pred aT) (f : aT -> rT) := exists2 g, prop_in1 d (inPhantom (cancel f g)) @@ -1602,59 +1771,30 @@ Definition bijective_on aT rT (cd : mem_pred rT) (f : aT -> rT) := exists2 g, prop_on1 cd (Phantom _ (cancel f)) (onPhantom (cancel f) g) & prop_in1 cd (inPhantom (cancel g f)). -Notation "{ 'for' x , P }" := - (prop_for x (inPhantom P)) - (at level 0, format "{ 'for' x , P }") : type_scope. - -Notation "{ 'in' d , P }" := - (prop_in1 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d , P }") : type_scope. - +Notation "{ 'for' x , P }" := (prop_for x (inPhantom P)) : type_scope. +Notation "{ 'in' d , P }" := (prop_in1 (mem d) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 , P }" := - (prop_in11 (mem d1) (mem d2) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 , P }") : type_scope. - -Notation "{ 'in' d & , P }" := - (prop_in2 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d & , P }") : type_scope. - + (prop_in11 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & , P }" := (prop_in2 (mem d) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 & d3 , P }" := - (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 & d3 , P }") : type_scope. - + (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & & d3 , P }" := - (prop_in21 (mem d1) (mem d3) (inPhantom P)) - (at level 0, format "{ 'in' d1 & & d3 , P }") : type_scope. - + (prop_in21 (mem d1) (mem d3) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 & , P }" := - (prop_in12 (mem d1) (mem d2) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 & , P }") : type_scope. - -Notation "{ 'in' d & & , P }" := - (prop_in3 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d & & , P }") : type_scope. - + (prop_in12 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & & , P }" := (prop_in3 (mem d) (inPhantom P)) : type_scope. Notation "{ 'on' cd , P }" := - (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) - (at level 0, format "{ 'on' cd , P }") : type_scope. + (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. Notation "{ 'on' cd & , P }" := - (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) - (at level 0, format "{ 'on' cd & , P }") : type_scope. - -Local Arguments onPhantom {_%type_scope} _ _. + (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. +Local Arguments onPhantom : clear scopes. Notation "{ 'on' cd , P & g }" := - (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) - (at level 0, format "{ 'on' cd , P & g }") : type_scope. - -Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) - (at level 0, f at level 8, - format "{ 'in' d , 'bijective' f }") : type_scope. - -Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) - (at level 0, f at level 8, - format "{ 'on' cd , 'bijective' f }") : type_scope. + (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) : type_scope. +Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) : type_scope. +Notation "{ 'on' cd , 'bijective' f }" := + (bijective_on (mem cd) f) : type_scope. (** Weakening and monotonicity lemmas for localized predicates. @@ -1666,7 +1806,7 @@ Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) Section LocalGlobal. Variables T1 T2 T3 : predArgType. -Variables (D1 : pred T1) (D2 : pred T2) (D3 : pred T3). +Variables (D1 : {pred T1}) (D2 : {pred T2}) (D3 : {pred T3}). Variables (d1 d1' : mem_pred T1) (d2 d2' : mem_pred T2) (d3 d3' : mem_pred T3). Variables (f f' : T1 -> T2) (g : T2 -> T1) (h : T3). Variables (P1 : T1 -> Prop) (P2 : T1 -> T2 -> Prop). @@ -1850,7 +1990,7 @@ End MonoHomoMorphismTheory. Section MonoHomoMorphismTheory_in. Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). -Variable (aD : pred aT). +Variable (aD : {pred aT}). Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). Notation rD := [pred x | g x \in aD]. diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 2a84469af0..56f17703ff 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -426,8 +426,8 @@ let mk_anon_id t gl_ids = (set s i (Char.chr (Char.code (get s i) + 1)); s) in Id.of_string_soft (Bytes.to_string (loop (n - 1))) -let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast -let convert_concl t = Tactics.convert_concl t DEFAULTcast +let convert_concl_no_check t = Tactics.convert_concl ~check:false t DEFAULTcast +let convert_concl ~check t = Tactics.convert_concl ~check t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with @@ -799,7 +799,7 @@ let discharge_hyp (id', (id, mode)) gl = | NamedDecl.LocalDef (_, v, t), _ -> let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in Proofview.V82.of_tactic - (convert_concl (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl + (convert_concl ~check:true (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl (* wildcard names *) let clear_wilds wilds gl = @@ -828,10 +828,12 @@ let view_error s gv = open Locus (****************************** tactics ***********************************) -let rewritetac dir c = +let rewritetac ?(under=false) dir c = (* Due to the new optional arg ?tac, application shouldn't be too partial *) + let open Proofview.Notations in Proofview.V82.of_tactic begin - Equality.general_rewrite (dir = L2R) AllOccurrences true false c + Equality.general_rewrite (dir = L2R) AllOccurrences true false c <*> + if under then Proofview.cycle 1 else Proofview.tclUNIT () end (**********************`:********* hooks ************************************) @@ -973,7 +975,7 @@ let dependent_apply_error = * * Refiner.refiner that does not handle metas with a non ground type but works * with dependently typed higher order metas. *) -let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = +let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t gl = if with_evars then let refine gl = let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in @@ -985,8 +987,11 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = pf_partial_solution gl t gs in Proofview.(V82.of_tactic - (tclTHEN (V82.tactic refine) - (if with_shelve then shelve_unifiable else tclUNIT ()))) gl + (Tacticals.New.tclTHENLIST [ + V82.tactic refine; + (if with_shelve then shelve_unifiable else tclUNIT ()); + (if first_goes_last then cycle 1 else tclUNIT ()) + ])) gl else let t, gl = if n = 0 then t, gl else let sigma, si = project gl, sig_it gl in @@ -1001,21 +1006,17 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = | _ -> assert false in loop sigma t [] n in pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); - Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t) gl + Proofview.(V82.of_tactic + (Tacticals.New.tclTHENLIST [ + V82.tactic (Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t)); + (if first_goes_last then cycle 1 else tclUNIT ()) + ])) gl let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = - let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in let uct = Evd.evar_universe_context (fst oc) in - let n, oc = pf_abs_evars_pirrel gl (fst oc, EConstr.Unsafe.to_constr (snd oc)) in + let n, oc = pf_abs_evars_pirrel gl (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (snd oc)) in let gl = pf_unsafe_merge_uc uct gl in - let oc = if not first_goes_last || n <= 1 then oc else - let l, c = decompose_lam oc in - if not (List.for_all_i (fun i (_,t) -> Vars.closedn ~-i t) (1-n) l) then oc else - compose_lam (let xs,y = List.chop (n-1) l in y @ xs) - (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) - in - pp(lazy(str"after: " ++ Printer.pr_constr_env (pf_env gl) (project gl) oc)); - try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl + try applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc) gl with e when CErrors.noncritical e -> raise dependent_apply_error (* We wipe out all the keywords generated by the grammar rules we defined. *) @@ -1169,7 +1170,7 @@ let gentac gen gl = ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); let gl = pf_merge_uc ucst gl in if conv - then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (old_cleartac clr) gl + then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl else genclrtac cl [c] clr gl let genstac (gens, clr) = @@ -1214,7 +1215,7 @@ let unprotecttac gl = let prot, _ = EConstr.destConst (project gl) c in Tacticals.onClause (fun idopt -> let hyploc = Option.map (fun id -> id, InHyp) idopt in - Proofview.V82.of_tactic (Tactics.reduct_option + Proofview.V82.of_tactic (Tactics.reduct_option ~check:false (Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fBETA; @@ -1281,10 +1282,10 @@ let clr_of_wgen gen clrs = match gen with | clr, _ -> old_cleartac clr :: clrs -let reduct_in_concl t = Tactics.reduct_in_concl (t, DEFAULTcast) +let reduct_in_concl ~check t = Tactics.reduct_in_concl ~check (t, DEFAULTcast) let unfold cl = let module R = Reductionops in let module F = CClosure.RedFlags in - reduct_in_concl (R.clos_norm_flags (F.mkflags + reduct_in_concl ~check:false (R.clos_norm_flags (F.mkflags (List.map (fun c -> F.fCONST (fst (destConst (EConstr.Unsafe.to_constr c)))) cl @ [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) @@ -1408,8 +1409,6 @@ let tclINTRO_ANON ?seed () = | Some seed -> tclINTRO ~id:(Seed seed) ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> - let convert_concl_no_check t = - Tactics.convert_concl_no_check t DEFAULTcast in let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with @@ -1540,5 +1539,10 @@ let get g = end +let is_construct_ref sigma c r = + EConstr.isConstruct sigma c && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r +let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r +let is_const_ref sigma c r = + EConstr.isConst sigma c && GlobRef.equal (ConstRef (fst(EConstr.destConst sigma c))) r (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 9662daa7c7..575f016014 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -252,7 +252,7 @@ val ssrevaltac : Tacinterp.interp_sign -> Tacinterp.Value.t -> unit Proofview.tactic val convert_concl_no_check : EConstr.t -> unit Proofview.tactic -val convert_concl : EConstr.t -> unit Proofview.tactic +val convert_concl : check:bool -> EConstr.t -> unit Proofview.tactic val red_safe : Reductionops.reduction_function -> @@ -312,6 +312,7 @@ val applyn : with_evars:bool -> ?beta:bool -> ?with_shelve:bool -> + ?first_goes_last:bool -> int -> EConstr.t -> v82tac exception NotEnoughProducts @@ -348,7 +349,7 @@ val resolve_typeclasses : (*********************** Wrapped Coq tactics *****************************) -val rewritetac : ssrdir -> EConstr.t -> tactic +val rewritetac : ?under:bool -> ssrdir -> EConstr.t -> tactic type name_hint = (int * EConstr.types array) option ref @@ -482,3 +483,7 @@ module MakeState(S : StateType) : sig val get : Proofview.Goal.t -> S.state end + +val is_ind_ref : Evd.evar_map -> EConstr.t -> Names.GlobRef.t -> bool +val is_construct_ref : Evd.evar_map -> EConstr.t -> Names.GlobRef.t -> bool +val is_const_ref : Evd.evar_map -> EConstr.t -> Names.GlobRef.t -> bool diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 4721e19a8b..5e3e8ce5fb 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -28,6 +28,11 @@ Declare ML Module "ssreflect_plugin". argumentType c == the T such that c : forall x : T, P x. returnType c == the R such that c : T -> R. {type of c for s} == P s where c : forall x : T, P x. + nonPropType == an interface for non-Prop Types: a nonPropType coerces + to a Type, and only types that do _not_ have sort + Prop are canonical nonPropType instances. This is + useful for applied views (see mid-file comment). + notProp T == the nonPropType instance for type T. phantom T v == singleton type with inhabitant Phantom T v. phant T == singleton type with inhabitant Phant v. =^~ r == the converse of rewriting rule r (e.g., in a @@ -57,8 +62,6 @@ Declare ML Module "ssreflect_plugin". More information about these definitions and their use can be found in the ssreflect manual, and in specific comments below. **) - - Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -77,7 +80,8 @@ Reserved Notation "(* 69 *)" (at level 69). (** Non ambiguous keyword to check if the SsrSyntax module is imported **) Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). -Reserved Notation "<hidden n >" (at level 200). +Reserved Notation "<hidden n >" (at level 0, n at level 0, + format "<hidden n >"). Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). End SsrSyntax. @@ -85,6 +89,39 @@ End SsrSyntax. Export SsrMatchingSyntax. Export SsrSyntax. +(** Save primitive notation that will be overloaded. **) +Local Notation CoqGenericIf c vT vF := (if c then vT else vF) (only parsing). +Local Notation CoqGenericDependentIf c x R vT vF := + (if c as x return R then vT else vF) (only parsing). +Local Notation CoqCast x T := (x : T) (only parsing). + +(** Reserve notation that introduced in this file. **) +Reserved Notation "'if' c 'then' vT 'else' vF" (at level 200, + c, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, x ident, only parsing). + +Reserved Notation "x : T" (at level 100, right associativity, + format "'[hv' x '/ ' : T ']'"). +Reserved Notation "T : 'Type'" (at level 100, format "T : 'Type'"). +Reserved Notation "P : 'Prop'" (at level 100, format "P : 'Prop'"). + +Reserved Notation "[ 'the' sT 'of' v 'by' f ]" (at level 0, + format "[ 'the' sT 'of' v 'by' f ]"). +Reserved Notation "[ 'the' sT 'of' v ]" (at level 0, + format "[ 'the' sT 'of' v ]"). +Reserved Notation "{ 'type' 'of' c 'for' s }" (at level 0, + format "{ 'type' 'of' c 'for' s }"). + +Reserved Notation "=^~ r" (at level 100, format "=^~ r"). + +Reserved Notation "[ 'unlockable' 'of' C ]" (at level 0, + format "[ 'unlockable' 'of' C ]"). +Reserved Notation "[ 'unlockable' 'fun' C ]" (at level 0, + format "[ 'unlockable' 'fun' C ]"). + (** To define notations for tactic in intro patterns. When "=> /t" is parsed, "t:%ssripat" is actually interpreted. **) @@ -100,32 +137,28 @@ Delimit Scope ssripat_scope with ssripat. Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. -Notation "'if' c 'then' v1 'else' v2" := - (if c then v1 else v2) - (at level 200, c, v1, v2 at level 200, only parsing) : general_if_scope. +Notation "'if' c 'then' vT 'else' vF" := + (CoqGenericIf c vT vF) (only parsing) : general_if_scope. -Notation "'if' c 'return' t 'then' v1 'else' v2" := - (if c return t then v1 else v2) - (at level 200, c, t, v1, v2 at level 200, only parsing) : general_if_scope. +Notation "'if' c 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c c R vT vF) (only parsing) : general_if_scope. -Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := - (if c as x return t then v1 else v2) - (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) - : general_if_scope. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c x R vT vF) (only parsing) : general_if_scope. (** Force boolean interpretation of simple if expressions. **) Declare Scope boolean_if_scope. Delimit Scope boolean_if_scope with BOOL_IF. -Notation "'if' c 'return' t 'then' v1 'else' v2" := - (if c%bool is true in bool return t then v1 else v2) : boolean_if_scope. +Notation "'if' c 'return' R 'then' vT 'else' vF" := + (if c is true as c in bool return R then vT else vF) : boolean_if_scope. -Notation "'if' c 'then' v1 'else' v2" := - (if c%bool is true in bool return _ then v1 else v2) : boolean_if_scope. +Notation "'if' c 'then' vT 'else' vF" := + (if c%bool is true as _ in bool return _ then vT else vF) : boolean_if_scope. -Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := - (if c%bool is true as x in bool return t then v1 else v2) : boolean_if_scope. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (if c%bool is true as x in bool return R then vT else vF) : boolean_if_scope. Open Scope boolean_if_scope. @@ -149,19 +182,15 @@ Open Scope form_scope. precedence of the notation, which binds less tightly than application), and put printing boxes that print the type of a long definition on a separate line rather than force-fit it at the right margin. **) -Notation "x : T" := (x : T) - (at level 100, right associativity, - format "'[hv' x '/ ' : T ']'") : core_scope. +Notation "x : T" := (CoqCast x T) : core_scope. (** Allow the casual use of notations like nat * nat for explicit Type declarations. Note that (nat * nat : Type) is NOT equivalent to (nat * nat)%%type, whose inferred type is legacy type "Set". **) -Notation "T : 'Type'" := (T%type : Type) - (at level 100, only parsing) : core_scope. +Notation "T : 'Type'" := (CoqCast T%type Type) (only parsing) : core_scope. (** Allow similarly Prop annotation for, e.g., rewrite multirules. **) -Notation "P : 'Prop'" := (P%type : Prop) - (at level 100, only parsing) : core_scope. +Notation "P : 'Prop'" := (CoqCast P%type Prop) (only parsing) : core_scope. (** Constants for abstract: and #[#: name #]# intro pattern **) Definition abstract_lock := unit. @@ -170,8 +199,10 @@ Definition abstract_key := tt. Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := let: tt := lock in statement. -Notation "<hidden n >" := (abstract _ n _). -Notation "T (* n *)" := (abstract T n abstract_key). +Declare Scope ssr_scope. +Notation "<hidden n >" := (abstract _ n _) : ssr_scope. +Notation "T (* n *)" := (abstract T n abstract_key) : ssr_scope. +Open Scope ssr_scope. Register abstract_lock as plugins.ssreflect.abstract_lock. Register abstract_key as plugins.ssreflect.abstract_key. @@ -222,28 +253,27 @@ Local Arguments get_by _%type_scope _%type_scope _ _ _ _. Notation "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f _ _ ((fun v' (s : sT) => Put v' (f s) s) v _)) - (at level 0, only parsing) : form_scope. + (only parsing) : form_scope. -Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) - (at level 0, only parsing) : form_scope. +Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*) s s) _)) + (only parsing) : form_scope. (** - The following are "format only" versions of the above notations. Since Coq - doesn't provide this facility, we fake it by splitting the "the" keyword. + The following are "format only" versions of the above notations. We need to do this to prevent the formatter from being be thrown off by application collapsing, coercion insertion and beta reduction in the right hand side of the notations above. **) -Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. +Notation "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) + (only printing) : form_scope. -Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. +Notation "[ 'the' sT 'of' v ]" := (@get _ sT v _ _) + (only printing) : form_scope. (** We would like to recognize -Notation " #[# 'th' 'e' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) - (at level 0, format " #[# 'th' 'e' sT 'of' v : 'Type' #]#") : form_scope. +Notation " #[# 'the' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) + (at level 0, format " #[# 'the' sT 'of' v : 'Type' #]#") : form_scope. **) (** @@ -278,8 +308,7 @@ Definition argumentType T P & forall x : T, P x := T. Definition dependentReturnType T P & forall x : T, P x := P. Definition returnType aT rT & aT -> rT := rT. -Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) - (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. +Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) : type_scope. (** A generic "phantom" type (actually, a unit type with a phantom parameter). @@ -330,7 +359,7 @@ Notation unkeyed x := (let flex := x in flex). (** Ssreflect converse rewrite rule rule idiom. **) Definition ssr_converse R (r : R) := (Logic.I, r). -Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. +Notation "=^~ r" := (ssr_converse r) : form_scope. (** Term tagging (user-level). @@ -397,11 +426,11 @@ Ltac ssrdone0 := Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. -Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) - (at level 0, format "[ 'unlockable' 'of' C ]") : form_scope. +Notation "[ 'unlockable' 'of' C ]" := + (@Unlockable _ _ C (unlock _)) : form_scope. -Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) - (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. +Notation "[ 'unlockable' 'fun' C ]" := + (@Unlockable _ (fun _ => _) C (unlock _)) : form_scope. (** Generic keyed constant locking. **) @@ -418,7 +447,7 @@ Proof. by case: k. Qed. Canonical locked_with_unlockable T k x := @Unlockable T x (locked_with k x) (locked_withE k x). -(** More accurate variant of unlock, and safer alternative to locked_withE. **) +(** More accurate variant of unlock, and safer alternative to locked_withE. **) Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. Proof. exact: unlock. Qed. @@ -500,3 +529,199 @@ Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. Lemma abstract_context T (P : T -> Type) x : (forall Q, Q = P -> Q x) -> P x. Proof. by move=> /(_ P); apply. Qed. + +(*****************************************************************************) +(* Constants for under, to rewrite under binders using "Leibniz eta lemmas". *) + +Module Type UNDER_EQ. +Parameter Under_eq : + forall (R : Type), R -> R -> Prop. +Parameter Under_eq_from_eq : + forall (T : Type) (x y : T), @Under_eq T x y -> x = y. + +(** [Over_eq, over_eq, over_eq_done]: for "by rewrite over_eq" *) +Parameter Over_eq : + forall (R : Type), R -> R -> Prop. +Parameter over_eq : + forall (T : Type) (x : T) (y : T), @Under_eq T x y = @Over_eq T x y. +Parameter over_eq_done : + forall (T : Type) (x : T), @Over_eq T x x. +(* We need both hints below, otherwise the test-suite does not pass *) +Hint Extern 0 (@Over_eq _ _ _) => solve [ apply over_eq_done ] : core. +(* => for [test-suite/ssr/under.v:test_big_patt1] *) +Hint Resolve over_eq_done : core. +(* => for [test-suite/ssr/over.v:test_over_1_1] *) + +(** [under_eq_done]: for Ltac-style over *) +Parameter under_eq_done : + forall (T : Type) (x : T), @Under_eq T x x. +Notation "''Under[' x ]" := (@Under_eq _ x _) + (at level 8, format "''Under[' x ]", only printing). +End UNDER_EQ. + +Module Export Under_eq : UNDER_EQ. +Definition Under_eq := @eq. +Lemma Under_eq_from_eq (T : Type) (x y : T) : + @Under_eq T x y -> x = y. +Proof. by []. Qed. +Definition Over_eq := Under_eq. +Lemma over_eq : + forall (T : Type) (x : T) (y : T), @Under_eq T x y = @Over_eq T x y. +Proof. by []. Qed. +Lemma over_eq_done : + forall (T : Type) (x : T), @Over_eq T x x. +Proof. by []. Qed. +Lemma under_eq_done : + forall (T : Type) (x : T), @Under_eq T x x. +Proof. by []. Qed. +End Under_eq. + +Register Under_eq as plugins.ssreflect.Under_eq. +Register Under_eq_from_eq as plugins.ssreflect.Under_eq_from_eq. + +Module Type UNDER_IFF. +Parameter Under_iff : Prop -> Prop -> Prop. +Parameter Under_iff_from_iff : forall x y : Prop, @Under_iff x y -> x <-> y. + +(** [Over_iff, over_iff, over_iff_done]: for "by rewrite over_iff" *) +Parameter Over_iff : Prop -> Prop -> Prop. +Parameter over_iff : + forall (x : Prop) (y : Prop), @Under_iff x y = @Over_iff x y. +Parameter over_iff_done : + forall (x : Prop), @Over_iff x x. +Hint Extern 0 (@Over_iff _ _) => solve [ apply over_iff_done ] : core. +Hint Resolve over_iff_done : core. + +(** [under_iff_done]: for Ltac-style over *) +Parameter under_iff_done : + forall (x : Prop), @Under_iff x x. +Notation "''Under[' x ]" := (@Under_iff x _) + (at level 8, format "''Under[' x ]", only printing). +End UNDER_IFF. + +Module Export Under_iff : UNDER_IFF. +Definition Under_iff := iff. +Lemma Under_iff_from_iff (x y : Prop) : + @Under_iff x y -> x <-> y. +Proof. by []. Qed. +Definition Over_iff := Under_iff. +Lemma over_iff : + forall (x : Prop) (y : Prop), @Under_iff x y = @Over_iff x y. +Proof. by []. Qed. +Lemma over_iff_done : + forall (x : Prop), @Over_iff x x. +Proof. by []. Qed. +Lemma under_iff_done : + forall (x : Prop), @Under_iff x x. +Proof. by []. Qed. +End Under_iff. + +Register Under_iff as plugins.ssreflect.Under_iff. +Register Under_iff_from_iff as plugins.ssreflect.Under_iff_from_iff. + +Definition over := (over_eq, over_iff). + +Ltac over := + by [ apply: Under_eq.under_eq_done + | apply: Under_iff.under_iff_done + | rewrite over + ]. + +(** An interface for non-Prop types; used to avoid improper instantiation + of polymorphic lemmas with on-demand implicits when they are used as views. + For example: Some_inj {T} : forall x y : T, Some x = Some y -> x = y. + Using move/Some_inj on a goal of the form Some n = Some 0 will fail: + SSReflect will interpret the view as @Some_inj ?T _top_assumption_ + since this is the well-typed application of the view with the minimal + number of inserted evars (taking ?T := Some n = Some 0), and then will + later complain that it cannot erase _top_assumption_ after having + abstracted the viewed assumption. Making x and y maximal implicits + would avoid this and force the intended @Some_inj nat x y _top_assumption_ + interpretation, but is undesireable as it makes it harder to use Some_inj + with the many SSReflect and MathComp lemmas that have an injectivity + premise. Specifying {T : nonPropType} solves this more elegantly, as then + (?T : Type) no longer unifies with (Some n = Some 0), which has sort Prop. + **) + +Module NonPropType. + +(** Implementation notes: + We rely on three interface Structures: + - test_of r, the middle structure, performs the actual check: it has two + canonical instances whose 'condition' projection are maybeProj (?P : Prop) + and tt, and which set r := true and r := false, respectively. Unifying + condition (?t : test_of ?r) with maybeProj T will thus set ?r to true if + T is in Prop as the test_Prop T instance will apply, and otherwise simplify + maybeProp T to tt and use the test_negative instance and set ?r to false. + - call_of c r sets up a call to test_of on condition c with expected result r. + It has a default instance for its 'callee' projection to Type, which + sets c := maybeProj T and r := false whe unifying with a type T. + - type is a telescope on call_of c r, which checks that unifying test_of ?r1 + with c indeed sets ?r1 := r; the type structure bundles the 'test' instance + and its 'result' value along with its call_of c r projection. The default + instance essentially provides eta-expansion for 'type'. This is only + essential for the first 'result' projection to bool; using the instance + for other projection merely avoids spurrious delta expansions that would + spoil the notProp T notation. + In detail, unifying T =~= ?S with ?S : nonPropType, i.e., + (1) T =~= @callee (@condition (result ?S) (test ?S)) (result ?S) (frame ?S) + first uses the default call instance with ?T := T to reduce (1) to + (2a) @condition (result ?S) (test ?S) =~= maybeProp T + (3) result ?S =~= false + (4) frame ?S =~= call T + along with some trivial universe-related checks which are irrelevant here. + Then the unification tries to use the test_Prop instance to reduce (2a) to + (6a) result ?S =~= true + (7a) ?P =~= T with ?P : Prop + (8a) test ?S =~= test_Prop ?P + Now the default 'check' instance with ?result := true resolves (6a) as + (9a) ?S := @check true ?test ?frame + Then (7a) can be solved precisely if T has sort at most (hence exactly) Prop, + and then (8a) is solved by the check instance, yielding ?test := test_Prop T, + and completing the solution of (2a), and _committing_ to it. But now (3) is + inconsistent with (9a), and this makes the entire problem (1) fails. + If on the othe hand T does not have sort Prop then (7a) fails and the + unification resorts to delta expanding (2a), which gives + (2b) @condition (result ?S) (test ?S) =~= tt + which is then reduced, using the test_negative instance, to + (6b) result ?S =~= false + (8b) test ?S =~= test_negative + Both are solved using the check default instance, as in the (2a) branch, giving + (9b) ?S := @check false test_negative ?frame + Then (3) and (4) are similarly soved using check, giving the final assignment + (9) ?S := notProp T + Observe that we _must_ perform the actual test unification on the arguments + of the initial canonical instance, and not on the instance itself as we do + in mathcomp/matrix and mathcomp/vector, because we want the unification to + fail when T has sort Prop. If both the test_of _and_ the result check + unifications were done as part of the structure telescope then the latter + would be a sub-problem of the former, and thus failing the check would merely + make the test_of unification backtrack and delta-expand and we would not get + failure. + **) + +Structure call_of (condition : unit) (result : bool) := Call {callee : Type}. +Definition maybeProp (T : Type) := tt. +Definition call T := Call (maybeProp T) false T. + +Structure test_of (result : bool) := Test {condition :> unit}. +Definition test_Prop (P : Prop) := Test true (maybeProp P). +Definition test_negative := Test false tt. + +Structure type := + Check {result : bool; test : test_of result; frame : call_of test result}. +Definition check result test frame := @Check result test frame. + +Module Exports. +Canonical call. +Canonical test_Prop. +Canonical test_negative. +Canonical check. +Notation nonPropType := type. +Coercion callee : call_of >-> Sortclass. +Coercion frame : type >-> call_of. +Notation notProp T := (@check false test_negative (call T)). +End Exports. + +End NonPropType. +Export NonPropType.Exports. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 350bb9019e..675e4d2457 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -194,7 +194,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let sort = Tacticals.elimination_sort_of_goal gl in let gl, elim = if not is_case then - let t,gl= pf_fresh_global (Indrec.lookup_eliminator (kn,i) sort) gl in + let t,gl= pf_fresh_global (Indrec.lookup_eliminator env (kn,i) sort) gl in gl, t else Tacmach.pf_eapply (fun env sigma () -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 5abbc214de..93c0d5c236 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -19,7 +19,6 @@ open Context open Vars open Locus open Printer -open Globnames open Termops open Tacinterp @@ -119,7 +118,7 @@ let newssrcongrtac arg ist gl = match try Some (pf_unify_HO gl_c (pf_concl gl) c) with exn when CErrors.noncritical exn -> None with | Some gl_c -> - tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true (fs gl_c c))) (t_ok (proj gl_c)) gl | None -> t_fail () gl in let mk_evar gl ty = @@ -277,7 +276,7 @@ let unfoldintac occ rdx t (kt,_) gl = try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl concl) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl) gl ;; let foldtac occ rdx ft gl = @@ -304,7 +303,7 @@ let foldtac occ rdx ft gl = let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl (EConstr.of_constr concl)) gl + Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.of_constr concl)) gl ;; let converse_dir = function L2R -> R2L | R2L -> L2R @@ -327,20 +326,20 @@ let rule_id = mk_internal_id "rewrite rule" exception PRtype_error of (Environ.env * Evd.evar_map * Pretype_errors.pretype_error) option -let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +let id_map_redex _ sigma ~before:_ ~after = sigma, after + +let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (* ppdebug(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) let env = pf_env gl in let beta = Reductionops.clos_norm_flags CClosure.beta env sigma in - let sigma, p = - let sigma = Evd.create_evar_defs sigma in - let (sigma, ev) = Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in - (sigma, ev) - in + let sigma, new_rdx = map_redex env sigma ~before:rdx ~after:new_rdx in + let sigma, p = (* The resulting goal *) + Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in let pred = EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdx_ty pred in let elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in let sort = elimination_sort_of_goal gl in - let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator env ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) let elim, _ = destConst elim in let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in @@ -355,9 +354,10 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) | e when CErrors.noncritical e -> raise (PRtype_error None) in - ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr_env env sigma proof_ty)); + ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); + ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); try refine_with - ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof) gl with _ -> (* we generate a msg like: "Unable to find an instance for the variable" *) let hd_ty, miss = match EConstr.kind sigma c with @@ -381,11 +381,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr_env env sigma hd_ty)) ;; -let is_construct_ref sigma c r = - EConstr.isConstruct sigma c && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r -let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r - -let rwcltac cl rdx dir sr gl = +let rwcltac ?under ?map_redex cl rdx dir sr gl = let sr = let sigma, r = sr in let sigma = resolve_typeclasses ~where:r ~fail:false (pf_env gl) sigma in @@ -403,14 +399,14 @@ let rwcltac cl rdx dir sr gl = 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 - | AtomicType(e, a) when is_ind_ref sigma e c_eq -> + | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in - pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl | _ -> let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in let gl = pf_merge_uc_of sigma gl in - Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl + Proofview.V82.of_tactic (convert_concl ~check:true cl'), rewritetac ?under dir r', gl else let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = @@ -421,7 +417,7 @@ let rwcltac cl rdx dir sr gl = let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in let cltac = Proofview.V82.of_tactic (Tactics.clear [pattern_id; rule_id]) in - let rwtacs = [rewritetac dir (EConstr.mkVar rule_id); cltac] in + let rwtacs = [rewritetac ?under dir (EConstr.mkVar rule_id); cltac] in apply_type cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], tclTHENLIST (itacs @ rwtacs), gl in let cvtac' _ = @@ -439,7 +435,6 @@ let rwcltac cl rdx dir sr gl = in tclTHEN cvtac' rwtac gl - [@@@ocaml.warning "-3"] let lz_coq_prod = let prod = lazy (Coqlib.build_prod ()) in fun () -> Lazy.force prod @@ -451,7 +446,7 @@ let lz_setoid_relation = | Some (env', srel) when env' == env -> srel | _ -> let srel = - try Some (UnivGen.constr_of_global @@ + try Some (UnivGen.constr_of_monomorphic_global @@ Coqlib.find_reference "Class_setoid" ("Coq"::sdir) "RewriteRelation" [@ocaml.warning "-3"]) with _ -> None in last_srel := Some (env, srel); srel @@ -496,7 +491,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.(lib_ref "core.True.type"))) then + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_monomorphic_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 @@ -504,9 +499,9 @@ let rwprocess_rule dir rule gl = let sigma, rs2 = loop d sigma s a.(1) rs 0 in let s, sigma = sr sigma 1 in loop d sigma s a.(0) rs2 0 - | App (r_eq, a) when Hipattern.match_with_equality_type sigma t != None -> + | App (r_eq, a) when Hipattern.match_with_equality_type env sigma t != None -> let (ind, u) = EConstr.destInd sigma r_eq and rhs = Array.last a in - let np = Inductiveops.inductive_nparamdecls ind in + let np = Inductiveops.inductive_nparamdecls env ind in let indu = (ind, EConstr.EInstance.kind sigma u) in let ind_ct = Inductiveops.type_of_constructors env indu in let lhs0 = last_arg sigma (EConstr.of_constr (strip_prod_assum ind_ct.(0))) in @@ -547,7 +542,7 @@ let rwprocess_rule dir rule gl = in r_sigma, rules -let rwrxtac occ rdx_pat dir rule gl = +let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = let env = pf_env gl in let r_sigma, rules = rwprocess_rule dir rule gl in let find_rule rdx = @@ -585,7 +580,7 @@ let rwrxtac occ rdx_pat dir rule gl = let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in let (d, r), rdx = conclude concl in let r = Evd.merge_universe_context (pi1 r) (pi2 r), EConstr.of_constr (pi3 r) in - rwcltac (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl + rwcltac ?under ?map_redex (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl ;; let ssrinstancesofrule ist dir arg gl = @@ -614,7 +609,7 @@ let ssrinstancesofrule ist dir arg gl = let ipat_rewrite occ dir c gl = rwrxtac occ None dir (project gl, c) gl -let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = +let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = let fail = ref false in let interp_rpattern gl gc = try interp_rpattern gl gc @@ -628,7 +623,7 @@ let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = (match kind with | RWred sim -> simplintac occ rx sim | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt - | RWeq -> rwrxtac occ rx dir t) gl in + | RWeq -> rwrxtac ?under ?map_redex occ rx dir t) gl in let ctac = old_cleartac (interp_clr (project gl) (oclr, (fst gt, snd (interp gt gl)))) in if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl @@ -638,8 +633,8 @@ let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = (** The "rewrite" tactic *) -let ssrrewritetac ist rwargs = - tclTHENLIST (List.map (rwargtac ist) rwargs) +let ssrrewritetac ?under ?map_redex ist rwargs = + tclTHENLIST (List.map (rwargtac ?under ?map_redex ist) rwargs) (** The "unlock" tactic *) @@ -649,7 +644,7 @@ let unfoldtac occ ko t kt gl = let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in Proofview.V82.of_tactic - (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + (convert_concl ~check:true (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl let unlocktac ist args gl = let utac (occ, gt) gl = @@ -660,4 +655,3 @@ let unlocktac ist args gl = (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); Proofview.V82.of_tactic (Ssrelim.casetac key (fun ?seed:_ k -> k)) ] in tclTHENLIST (List.map utac args @ ktacs) gl - diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli index bbcd6b900a..601968d511 100644 --- a/plugins/ssr/ssrequality.mli +++ b/plugins/ssr/ssrequality.mli @@ -48,13 +48,15 @@ val ssrinstancesofrule : Ssrast.ssrterm -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +(* map_redex (by default the identity on after) is called on the + * redex (before) and its replacement (after). It is used to + * "rename" binders by the under tactic *) val ssrrewritetac : + ?under:bool -> + ?map_redex:(Environ.env -> Evd.evar_map -> + before:EConstr.t -> after:EConstr.t -> Evd.evar_map * EConstr.t) -> Ltac_plugin.Tacinterp.interp_sign -> - ((Ssrast.ssrdir * (int * Ssrast.ssrmmod)) * - (((Ssrast.ssrhyps option * Ssrmatching.occ) * - Ssrmatching.rpattern option) * - (ssrwkind * Ssrast.ssrterm))) - list -> Tacmach.tactic + ssrrwarg list -> Tacmach.tactic val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> Tacmach.tactic diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index b51ffada0c..46af775296 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -219,25 +219,113 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Declare Scope fun_scope. -Delimit Scope fun_scope with FUN. -Open Scope fun_scope. +(** Parsing / printing declarations. *) +Reserved Notation "p .1" (at level 2, left associativity, format "p .1"). +Reserved Notation "p .2" (at level 2, left associativity, format "p .2"). +Reserved Notation "f ^~ y" (at level 10, y at level 8, no associativity, + format "f ^~ y"). +Reserved Notation "@^~ x" (at level 10, x at level 8, no associativity, + format "@^~ x"). +Reserved Notation "[ 'eta' f ]" (at level 0, format "[ 'eta' f ]"). +Reserved Notation "'fun' => E" (at level 200, format "'fun' => E"). + +Reserved Notation "[ 'fun' : T => E ]" (at level 0, + format "'[hv' [ 'fun' : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x : T => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y : T => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x ( y : T ) => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" (at level 0, + x ident, y ident, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). + +Reserved Notation "f =1 g" (at level 70, no associativity). +Reserved Notation "f =1 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f =2 g" (at level 70, no associativity). +Reserved Notation "f =2 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f \o g" (at level 50, format "f \o '/ ' g"). +Reserved Notation "f \; g" (at level 60, right associativity, + format "f \; '/ ' g"). + +Reserved Notation "{ 'morph' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a >-> r }"). +Reserved Notation "{ 'morph' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a }"). +Reserved Notation "{ 'morph' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a >-> r }"). +Reserved Notation "{ 'morph' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a }"). +Reserved Notation "{ 'homo' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a >-> r }"). +Reserved Notation "{ 'homo' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a }"). +Reserved Notation "{ 'homo' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a >-> r }"). +Reserved Notation "{ 'homo' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a }"). +Reserved Notation "{ 'homo' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y /~ a }"). +Reserved Notation "{ 'mono' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a >-> r }"). +Reserved Notation "{ 'mono' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a }"). +Reserved Notation "{ 'mono' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a >-> r }"). +Reserved Notation "{ 'mono' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a }"). +Reserved Notation "{ 'mono' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y /~ a }"). + +Reserved Notation "@ 'id' T" (at level 10, T at level 8, format "@ 'id' T"). +Reserved Notation "@ 'sval'" (at level 10, format "@ 'sval'"). -(** Notations for argument transpose **) -Notation "f ^~ y" := (fun x => f x y) - (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. -Notation "@^~ x" := (fun f => f x) - (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. +(** + Syntax for defining auxiliary recursive function. + Usage: + Section FooDefinition. + Variables (g1 : T1) (g2 : T2). (globals) + Fixoint foo_auxiliary (a3 : T3) ... := + body, using #[#rec e3, ... #]# for recursive calls + where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. + Definition foo x y .. := #[#rec e1, ... #]#. + + proofs about foo + End FooDefinition. **) + +Reserved Notation "[ 'rec' a ]" (at level 0, + format "[ 'rec' a ]"). +Reserved Notation "[ 'rec' a , b ]" (at level 0, + format "[ 'rec' a , b ]"). +Reserved Notation "[ 'rec' a , b , c ]" (at level 0, + format "[ 'rec' a , b , c ]"). +Reserved Notation "[ 'rec' a , b , c , d ]" (at level 0, + format "[ 'rec' a , b , c , d ]"). +Reserved Notation "[ 'rec' a , b , c , d , e ]" (at level 0, + format "[ 'rec' a , b , c , d , e ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i , j ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i , j ]"). Declare Scope pair_scope. Delimit Scope pair_scope with PAIR. Open Scope pair_scope. (** Notations for pair/conjunction projections **) -Notation "p .1" := (fst p) - (at level 2, left associativity, format "p .1") : pair_scope. -Notation "p .2" := (snd p) - (at level 2, left associativity, format "p .2") : pair_scope. +Notation "p .1" := (fst p) : pair_scope. +Notation "p .2" := (snd p) : pair_scope. Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). @@ -291,41 +379,13 @@ Canonical wrap T x := @Wrap T x. Prenex Implicits unwrap wrap Wrap. -(** - Syntax for defining auxiliary recursive function. - Usage: - Section FooDefinition. - Variables (g1 : T1) (g2 : T2). (globals) - Fixoint foo_auxiliary (a3 : T3) ... := - body, using #[#rec e3, ... #]# for recursive calls - where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. - Definition foo x y .. := #[#rec e1, ... #]#. - + proofs about foo - End FooDefinition. **) +Declare Scope fun_scope. +Delimit Scope fun_scope with FUN. +Open Scope fun_scope. -Reserved Notation "[ 'rec' a0 ]" - (at level 0, format "[ 'rec' a0 ]"). -Reserved Notation "[ 'rec' a0 , a1 ]" - (at level 0, format "[ 'rec' a0 , a1 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). +(** Notations for argument transpose **) +Notation "f ^~ y" := (fun x => f x y) : fun_scope. +Notation "@^~ x" := (fun f => f x) : fun_scope. (** Definitions and notation for explicit functions with simplification, @@ -344,33 +404,19 @@ Coercion fun_of_simpl : simpl_fun >-> Funclass. End SimplFun. -Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) - (at level 0, - format "'[hv' [ 'fun' : T => '/ ' E ] ']'") : fun_scope. - -Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) - (at level 0, x ident, - format "'[hv' [ 'fun' x => '/ ' E ] ']'") : fun_scope. - +Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) : fun_scope. +Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) : fun_scope. +Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) : fun_scope. Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E)) - (at level 0, x ident, only parsing) : fun_scope. - -Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) - (at level 0, x ident, y ident, - format "'[hv' [ 'fun' x y => '/ ' E ] ']'") : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - -Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := - (fun x : xT => [fun y : yT => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. + (only parsing) : fun_scope. +Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" := (fun x : T => [fun y : U => E]) + (only parsing) : fun_scope. (** For delta functions in eqtype.v. **) Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. @@ -402,51 +448,38 @@ Typeclasses Opaque eqrel. Hint Resolve frefl rrefl : core. -Notation "f1 =1 f2" := (eqfun f1 f2) - (at level 70, no associativity) : fun_scope. -Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) - (at level 70, f2 at next level, A at level 90) : fun_scope. -Notation "f1 =2 f2" := (eqrel f1 f2) - (at level 70, no associativity) : fun_scope. -Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) - (at level 70, f2 at next level, A at level 90) : fun_scope. +Notation "f1 =1 f2" := (eqfun f1 f2) : fun_scope. +Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) : fun_scope. +Notation "f1 =2 f2" := (eqrel f1 f2) : fun_scope. +Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) : fun_scope. Section Composition. Variables A B C : Type. -Definition funcomp u (f : B -> A) (g : C -> B) x := let: tt := u in f (g x). -Definition catcomp u g f := funcomp u f g. -Local Notation comp := (funcomp tt). - +Definition comp (f : B -> A) (g : C -> B) x := f (g x). +Definition catcomp g f := comp f g. Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x). Lemma eq_comp f f' g g' : f =1 f' -> g =1 g' -> comp f g =1 comp f' g'. -Proof. by move=> eq_ff' eq_gg' x; rewrite /= eq_gg' eq_ff'. Qed. +Proof. by move=> eq_ff' eq_gg' x; rewrite /comp eq_gg' eq_ff'. Qed. End Composition. -Notation comp := (funcomp tt). -Notation "@ 'comp'" := (fun A B C => @funcomp A B C tt). -Notation "f1 \o f2" := (comp f1 f2) - (at level 50, format "f1 \o '/ ' f2") : fun_scope. -Notation "f1 \; f2" := (catcomp tt f1 f2) - (at level 60, right associativity, format "f1 \; '/ ' f2") : fun_scope. +Arguments comp {A B C} f g x /. +Arguments catcomp {A B C} g f x /. +Notation "f1 \o f2" := (comp f1 f2) : fun_scope. +Notation "f1 \; f2" := (catcomp f1 f2) : fun_scope. -Notation "[ 'eta' f ]" := (fun x => f x) - (at level 0, format "[ 'eta' f ]") : fun_scope. +Notation "[ 'eta' f ]" := (fun x => f x) : fun_scope. -Notation "'fun' => E" := (fun _ => E) (at level 200, only parsing) : fun_scope. +Notation "'fun' => E" := (fun _ => E) : fun_scope. Notation id := (fun x => x). -Notation "@ 'id' T" := (fun x : T => x) - (at level 10, T at level 8, only parsing) : fun_scope. +Notation "@ 'id' T" := (fun x : T => x) (only parsing) : fun_scope. -Definition id_head T u x : T := let: tt := u in x. -Definition explicit_id_key := tt. -Notation idfun := (id_head tt). -Notation "@ 'idfun' T " := (@id_head T explicit_id_key) - (at level 10, T at level 8, format "@ 'idfun' T") : fun_scope. +Definition idfun T x : T := x. +Arguments idfun {T} x /. Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. @@ -542,74 +575,33 @@ Definition monomorphism_2 (aR rR : _ -> _ -> sT) := End Morphism. Notation "{ 'morph' f : x / a >-> r }" := - (morphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'morph' f : x / a >-> r }") : type_scope. - + (morphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'morph' f : x / a }" := - (morphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'morph' f : x / a }") : type_scope. - + (morphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'morph' f : x y / a >-> r }" := - (morphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'morph' f : x y / a >-> r }") : type_scope. - + (morphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'morph' f : x y / a }" := - (morphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'morph' f : x y / a }") : type_scope. - + (morphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'homo' f : x / a >-> r }" := - (homomorphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'homo' f : x / a >-> r }") : type_scope. - + (homomorphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'homo' f : x / a }" := - (homomorphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'homo' f : x / a }") : type_scope. - + (homomorphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'homo' f : x y / a >-> r }" := - (homomorphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y / a >-> r }") : type_scope. - + (homomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'homo' f : x y / a }" := - (homomorphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y / a }") : type_scope. - + (homomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'homo' f : x y /~ a }" := - (homomorphism_2 f (fun y x => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y /~ a }") : type_scope. - + (homomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. Notation "{ 'mono' f : x / a >-> r }" := - (monomorphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'mono' f : x / a >-> r }") : type_scope. - + (monomorphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'mono' f : x / a }" := - (monomorphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'mono' f : x / a }") : type_scope. - + (monomorphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'mono' f : x y / a >-> r }" := - (monomorphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y / a >-> r }") : type_scope. - + (monomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'mono' f : x y / a }" := - (monomorphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y / a }") : type_scope. - + (monomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'mono' f : x y /~ a }" := - (monomorphism_2 f (fun y x => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y /~ a }") : type_scope. + (monomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. (** In an intuitionistic setting, we have two degrees of injectivity. The @@ -620,9 +612,6 @@ Notation "{ 'mono' f : x y /~ a }" := Section Injections. -(** - rT must come first so we can use @ to mitigate the Coq 1st order - unification bug (e..g., Coq can't infer rT from a "cancel" lemma). **) Variables (rT aT : Type) (f : aT -> rT). Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. @@ -650,10 +639,8 @@ Proof. by move=> fK <-. Qed. End Injections. -Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. - -(** Force implicits to use as a view. **) -Prenex Implicits Some_inj. +Lemma Some_inj {T : nonPropType} : injective (@Some T). +Proof. by move=> x y []. Qed. (** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 3cadc92bcc..4d4400a0f8 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -56,7 +56,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in - Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl')) (introid id) gl open Util @@ -161,7 +161,7 @@ let havetac ist let gl, ty = pfe_type_of gl t in let ctx, _ = EConstr.decompose_prod_n_assum (project gl) 1 ty in let assert_is_conv gl = - try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl + try Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c @@ -319,3 +319,172 @@ let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in basecuttac "ssr_suff" ty gl in Tacticals.tclTHENS ctac [htac; Tacticals.tclTHEN (old_cleartac clr) (introstac (binders@simpl))] + +open Proofview.Notations + +let is_app_evar sigma t = + match EConstr.kind sigma t with + | Constr.Evar _ -> true + | Constr.App(t,_) -> + begin match EConstr.kind sigma t with + | Constr.Evar _ -> true + | _ -> false end + | _ -> false + +let rec ncons n e = match n with + | 0 -> [] + | n when n > 0 -> e :: ncons (n - 1) e + | _ -> failwith "ncons" + +let intro_lock ipats = + let hnf' = Proofview.numgoals >>= fun ng -> + Proofview.tclDISPATCH + (ncons (ng - 1) ssrsmovetac @ [Proofview.tclUNIT ()]) in + let rec lock_eq () : unit Proofview.tactic = Proofview.Goal.enter begin fun _ -> + Proofview.tclORELSE + (Ssripats.tclIPAT [Ssripats.IOpTemporay; Ssripats.IOpEqGen (lock_eq ())]) + (fun _exn -> Proofview.Goal.enter begin fun gl -> + let c = Proofview.Goal.concl gl in + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + match EConstr.kind_of_type sigma c with + | Term.AtomicType(hd, args) when + Ssrcommon.is_const_ref sigma hd (Coqlib.lib_ref "core.iff.type") && + Array.length args = 2 && is_app_evar sigma args.(1) -> + Tactics.New.refine ~typecheck:true (fun sigma -> + let sigma, under_iff = + Ssrcommon.mkSsrConst "Under_iff" env sigma in + let sigma, under_from_iff = + Ssrcommon.mkSsrConst "Under_iff_from_iff" env sigma in + let ty = EConstr.mkApp (under_iff,args) in + let sigma, t = Evarutil.new_evar env sigma ty in + sigma, EConstr.mkApp(under_from_iff,Array.append args [|t|])) + | _ -> + let t = Reductionops.whd_all env sigma c in + match EConstr.kind_of_type sigma t with + | Term.AtomicType(hd, args) when + Ssrcommon.is_ind_ref sigma hd (Coqlib.lib_ref "core.eq.type") && + Array.length args = 3 && is_app_evar sigma args.(2) -> + Tactics.New.refine ~typecheck:true (fun sigma -> + let sigma, under = + Ssrcommon.mkSsrConst "Under_eq" env sigma in + let sigma, under_from_eq = + Ssrcommon.mkSsrConst "Under_eq_from_eq" env sigma in + let ty = EConstr.mkApp (under,args) in + let sigma, t = Evarutil.new_evar env sigma ty in + sigma, EConstr.mkApp(under_from_eq,Array.append args [|t|])) + | _ -> + ppdebug(lazy Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); + + Proofview.tclUNIT () + end) + end + in + hnf' <*> Ssripats.tclIPATssr ipats <*> lock_eq () + +let pretty_rename evar_map term varnames = + let rec aux term vars = + try + match vars with + | [] -> term + | Names.Name.Anonymous :: varnames -> + let name, types, body = EConstr.destLambda evar_map term in + let res = aux body varnames in + EConstr.mkLambda (name, types, res) + | Names.Name.Name _ as name :: varnames -> + let { Context.binder_relevance = r }, types, body = + EConstr.destLambda evar_map term in + let res = aux body varnames in + EConstr.mkLambda (Context.make_annot name r, types, res) + with DestKO -> term + in + aux term varnames + +let overtac = Proofview.V82.tactic (ssr_n_tac "over" ~-1) + +let check_numgoals ?(minus = 0) nh = + Proofview.numgoals >>= fun ng -> + if nh <> ng then + let errmsg = + str"Incorrect number of tactics" ++ spc() ++ + str"(expected "++int (ng - minus)++str(String.plural ng " tactic") ++ + str", was given "++ int (nh - minus)++str")." + in + CErrors.user_err errmsg + else + Proofview.tclUNIT () + +let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = + + (* total number of implied hints *) + let nh = List.length (snd hint) + (if hint = nullhint then 2 else 1) in + + let varnames = + let rec aux acc = function + | IPatId id :: rest -> aux (Names.Name.Name id :: acc) rest + | IPatClear _ :: rest -> aux acc rest + | IPatSimpl _ :: rest -> aux acc rest + | IPatAnon (One _ | Drop) :: rest -> + aux (Names.Name.Anonymous :: acc) rest + | _ -> List.rev acc in + aux [] @@ match ipats with + | None -> [] + | Some (IPatCase(Regular (l :: _)) :: _) -> l + | Some l -> l in + + (* If we find a "=> [|]" we add 1 | to get "=> [||]" for the extra + * goal (the one that is left once we run over) *) + let ipats = + match ipats with + | None -> [IPatNoop] + | Some l when pad_intro -> (* typically, ipats = Some [IPatAnon All] *) + let new_l = ncons (nh - 1) l in + [IPatCase(Regular (new_l @ [[]]))] + | Some (IPatCase(Regular []) :: _ as ipats) -> ipats + (* Erik: is the previous line correct/useful? *) + | Some (IPatCase(Regular l) :: rest) -> IPatCase(Regular(l @ [[]])) :: rest + | Some (IPatCase(Block _) :: _ as l) -> l + | Some l -> [IPatCase(Regular [l;[]])] in + + let map_redex env evar_map ~before:_ ~after:t = + ppdebug(lazy Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); + + let evar_map, ty = Typing.type_of env evar_map t in + let new_t = (* pretty-rename the bound variables *) + try begin match EConstr.destApp evar_map t with (f, ar) -> + let lam = Array.last ar in + ppdebug(lazy Pp.(str"under: mapping:" ++ + pr_econstr_env env evar_map lam)); + let new_lam = pretty_rename evar_map lam varnames in + let new_ar, len1 = Array.copy ar, pred (Array.length ar) in + new_ar.(len1) <- new_lam; + EConstr.mkApp (f, new_ar) + end with + | DestKO -> + ppdebug(lazy Pp.(str"under: cannot pretty-rename bound variables with destApp")); + t + in + ppdebug(lazy Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); + evar_map, new_t + in + let undertacs = + if hint = nohint then + Proofview.tclUNIT () + else + let betaiota = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in + (* Usefulness of check_numgoals: tclDISPATCH would be enough, + except for the error message w.r.t. the number of + provided/expected tactics, as the last one is implied *) + check_numgoals ~minus:1 nh <*> + Proofview.tclDISPATCH + ((List.map (function None -> overtac + | Some e -> ssrevaltac ist e <*> + overtac) + (if hint = nullhint then [None] else snd hint)) + @ [betaiota]) + in + let rew = + Proofview.V82.tactic + (Ssrequality.ssrrewritetac ~under:true ~map_redex ist [rule]) + in + rew <*> intro_lock ipats <*> undertacs diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli index 35e89dbcea..6dd01ca6fc 100644 --- a/plugins/ssr/ssrfwd.mli +++ b/plugins/ssr/ssrfwd.mli @@ -57,3 +57,16 @@ val sufftac : (bool * Tacinterp.Value.t option list)) -> Tacmach.tactic +(* pad_intro (by default false) indicates whether the intro-pattern + "=> i..." must be turned into "=> [i...|i...|i...|]" (n+1 branches, + assuming there are n provided tactics in the ssrhint argument + "do [...|...|...]"; it is useful when the intro-pattern is "=> *"). + Otherwise, "=> i..." is turned into "=> [i...|]". *) +val undertac : + ?pad_intro:bool -> + Ltac_plugin.Tacinterp.interp_sign -> + Ssrast.ssripats option -> Ssrequality.ssrrwarg -> + Ltac_plugin.Tacinterp.Value.t Ssrast.ssrhint -> unit Proofview.tactic + +val overtac : + unit Proofview.tactic diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 0ec5f1673a..27a558611e 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -86,6 +86,15 @@ GRAMMAR EXTEND Gram ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> { tac } ]]; END +(* Copy of ssrtacarg with LEVEL "3", useful for: "under ... do ..." *) +ARGUMENT EXTEND ssrtac3arg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } +| [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } +END +GRAMMAR EXTEND Gram + GLOBAL: ssrtac3arg; + ssrtac3arg: [[ tac = tactic_expr LEVEL "3" -> { tac } ]]; +END + { (* Lexically closed tactic for tacticals. *) @@ -224,20 +233,20 @@ let test_ssrslashnum b1 b2 strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "/" -> (match Util.stream_nth 1 strm with - | Tok.INT _ when b1 -> + | Tok.NUMERAL _ when b1 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" | Tok.KEYWORD "/=" when not b2 -> () | Tok.KEYWORD "/" -> if not b2 then () else begin match Util.stream_nth 3 strm with - | Tok.INT _ -> () + | Tok.NUMERAL _ -> () | _ -> raise Stream.Failure end | _ -> raise Stream.Failure) | Tok.KEYWORD "/" when not b1 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" when not b2 -> () - | Tok.INT _ when b2 -> + | Tok.NUMERAL _ when b2 -> (match Util.stream_nth 3 strm with | Tok.KEYWORD "=" -> () | _ -> raise Stream.Failure) @@ -248,7 +257,7 @@ let test_ssrslashnum b1 b2 strm = | Tok.KEYWORD "//" when not b1 -> (match Util.stream_nth 1 strm with | Tok.KEYWORD "=" when not b2 -> () - | Tok.INT _ when b2 -> + | Tok.NUMERAL _ when b2 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" -> () | _ -> raise Stream.Failure) @@ -360,8 +369,8 @@ let interp_index ist gl idx = | Some c -> let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc with - | _, Constrexpr.Numeral (s,b) -> - let n = int_of_string s in if b then n else -n + | _, Constrexpr.Numeral (b,{NumTok.int = s; frac = ""; exp = ""}) -> + let n = int_of_string s in (match b with SPlus -> n | SMinus -> -n) | _ -> raise Not_found end | None -> raise Not_found @@ -741,15 +750,33 @@ let pushIPatNoop = function | pats :: orpat -> (IPatNoop :: pats) :: orpat | [] -> [] +let test_ident_no_do strm = + match Util.stream_nth 0 strm with + | Tok.IDENT s when s <> "do" -> () + | _ -> raise Stream.Failure + +let test_ident_no_do = + Pcoq.Entry.of_parser "test_ident_no_do" test_ident_no_do + } +ARGUMENT EXTEND ident_no_do PRINTED BY { fun _ _ _ -> Names.Id.print } +| [ "YouShouldNotTypeThis" ident(id) ] -> { id } +END + + +GRAMMAR EXTEND Gram + GLOBAL: ident_no_do; + ident_no_do: [ [ test_ident_no_do; id = IDENT -> { Id.of_string id } ] ]; +END + ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } INTERPRETED BY { interp_ipats } GLOBALIZED BY { intern_ipats } | [ "_" ] -> { [IPatAnon Drop] } | [ "*" ] -> { [IPatAnon All] } | [ ">" ] -> { [IPatFastNondep] } - | [ ident(id) ] -> { [IPatId id] } + | [ ident_no_do(id) ] -> { [IPatId id] } | [ "?" ] -> { [IPatAnon (One None)] } | [ "+" ] -> { [IPatAnon Temporary] } | [ "++" ] -> { [IPatAnon Temporary; IPatAnon Temporary] } @@ -1047,6 +1074,13 @@ ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintar | [ ssrtacarg(arg) ] -> { mk_hint arg } END +(* Copy of ssrhintarg with LEVEL "3", useful for: "under ... do ..." *) +ARGUMENT EXTEND ssrhint3arg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg env sigma } +| [ "[" "]" ] -> { nullhint } +| [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } +| [ ssrtac3arg(arg) ] -> { mk_hint arg } +END + ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg env sigma } | [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } END @@ -1200,7 +1234,7 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c | BFrec (has_str, has_cast) :: h, - { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> + { v = CFix ( _, [_, Some {CAst.v = CStructRec locn}, bl, t, c]) } -> let bs = format_local_binders h bl in let bstr = if has_str then [Bstruct (Name locn.CAst.v)] else [] in bs @ bstr @ (if has_cast then [Bcast t] else []), c @@ -1424,7 +1458,7 @@ ARGUMENT EXTEND ssrfixfwd TYPED AS (ident * ssrfwd) PRINTED BY { pr_ssrfixfwd } | [] -> CErrors.user_err (Pp.str "Bad structural argument") in loop (names_of_local_assums lb) in let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in - let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in + let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some (CAst.make (CStructRec i))), lb, t', c']) in id, ((fk, h'), { ac with body = fix }) } END @@ -2652,6 +2686,34 @@ END { +let check_under_arg ((_dir,mult),((_occ,_rpattern),_rule)) = + if mult <> nomult then + CErrors.user_err Pp.(str"under does not support multipliers") + +} + + +TACTIC EXTEND under + | [ "under" ssrrwarg(arg) ] -> { + check_under_arg arg; + Ssrfwd.undertac ist None arg nohint + } + | [ "under" ssrrwarg(arg) ssrintros_ne(ipats) ] -> { + check_under_arg arg; + Ssrfwd.undertac ist (Some ipats) arg nohint + } + | [ "under" ssrrwarg(arg) ssrintros_ne(ipats) "do" ssrhint3arg(h) ] -> { + check_under_arg arg; + Ssrfwd.undertac ist (Some ipats) arg h + } + | [ "under" ssrrwarg(arg) "do" ssrhint3arg(h) ] -> { (* implicit "=> [*|*]" *) + check_under_arg arg; + Ssrfwd.undertac ~pad_intro:true ist (Some [IPatAnon All]) arg h + } +END + +{ + (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index bbe7bde78b..91ff432364 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -110,7 +110,7 @@ let endclausestac id_map clseq gl_id cl0 gl = | _ -> EConstr.map (project gl) unmark c in let utac hyp = Proofview.V82.of_tactic - (Tactics.convert_hyp_no_check (NamedDecl.map_constr unmark hyp)) in + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = Proofview.V82.of_tactic diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 0a0d9b12fa..08f028465b 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -183,7 +183,7 @@ GRAMMAR EXTEND Gram GLOBAL: gallina_ext; gallina_ext: [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> - { Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) } + { Vernacexpr.VernacSetOption (false, ["Printing"; "Implicit"; "Defensive"], Vernacexpr.OptionUnset) } ] ] ; END @@ -465,7 +465,7 @@ let interp_modloc mr = (* The unified, extended vernacular "Search" command *) let ssrdisplaysearch gr env t = - let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in Feedback.msg_info (hov 2 pr_res ++ fnl ()) } diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 537fd7d7b4..0a5c85f4ab 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -43,7 +43,7 @@ module AdaptorDb = struct term_view_adaptor_db := AdaptorMap.add k (t :: lk) !term_view_adaptor_db let subst_adaptor ( subst, (k, t as a)) = - let t' = Detyping.subst_glob_constr subst t in + let t' = Detyping.subst_glob_constr (Global.env()) subst t in if t' == t then a else k, t' let in_db = @@ -290,7 +290,7 @@ let finalize_view s0 ?(simple_types=true) p = Goal.enter_one ~__LOC__ begin fun g -> let env = Goal.env g in let sigma = Goal.sigma g in - let evars_of_p = Evd.evars_of_term (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in + let evars_of_p = Evd.evars_of_term sigma p in let filter x _ = Evar.Set.mem x evars_of_p in let sigma = Typeclasses.resolve_typeclasses ~fail:false ~filter env sigma in let p = Reductionops.nf_evar sigma p in @@ -307,7 +307,7 @@ Goal.enter_one ~__LOC__ begin fun g -> let und0 = (* Unassigned evars in the initial goal *) let sigma0 = Tacmach.project s0 in let g0info = Evd.find sigma0 (Tacmach.sig_it s0) in - let g0 = Evd.evars_of_filtered_evar_info g0info in + let g0 = Evd.evars_of_filtered_evar_info sigma0 g0info in List.filter (fun k -> Evar.Set.mem k g0) (List.map fst (Evar.Map.bindings (Evd.undefined_map sigma0))) in let rigid = rigid_of und0 in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1deb935d5c..adbcfb8f3b 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -529,8 +529,8 @@ exception FoundUnif of (evar_map * UState.t * tpattern) (* Note: we don't update env as we descend into the term, as the primitive *) (* unification procedure always rejects subterms with bound variables. *) -let dont_impact_evars_in cl = - let evs_in_cl = Evd.evars_of_term cl in +let dont_impact_evars_in sigma0 cl = + let evs_in_cl = Evd.evars_of_term sigma0 cl in fun sigma -> Evar.Set.for_all (fun k -> try let _ = Evd.find_undefined sigma k in true with Not_found -> false) evs_in_cl @@ -544,7 +544,7 @@ let dont_impact_evars_in cl = (* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) (* match a head let rigidly. *) let match_upats_FO upats env sigma0 ise orig_c = - let dont_impact_evars = dont_impact_evars_in orig_c in + let dont_impact_evars = dont_impact_evars_in sigma0 (EConstr.of_constr orig_c) in let rec loop c = let f, a = splay_app ise c in let i0 = ref (-1) in let fpats = @@ -586,7 +586,7 @@ let match_upats_FO upats env sigma0 ise orig_c = let match_upats_HO ~on_instance upats env sigma0 ise c = - let dont_impact_evars = dont_impact_evars_in c in + let dont_impact_evars = dont_impact_evars_in sigma0 (EConstr.of_constr c) in let it_did_match = ref false in let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = @@ -1299,7 +1299,7 @@ let ssrpatterntac _ist arg gl = let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) let () = diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index baa4ae0306..0f0f3953da 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -16,18 +16,17 @@ open Notation open Numeral open Pp open Names -open Ltac_plugin open Stdarg open Pcoq.Prim -let pr_numnot_option _ _ _ = function +let pr_numnot_option = function | Nop -> mt () | Warning n -> str "(warning after " ++ str n ++ str ")" | Abstract n -> str "(abstract after " ++ str n ++ str ")" } -ARGUMENT EXTEND numnotoption +VERNAC ARGUMENT EXTEND numnotoption PRINTED BY { pr_numnot_option } | [ ] -> { Nop } | [ "(" "warning" "after" bigint(waft) ")" ] -> { Warning waft } diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 525056e5f1..ec8c2338fb 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -56,17 +56,24 @@ let locate_z () = }, mkRefC q_z) else None -let locate_int () = +let locate_decimal () = let int = "num.int.type" in let uint = "num.uint.type" in - if Coqlib.has_ref int && Coqlib.has_ref uint + let dec = "num.decimal.type" in + if Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref dec then let q_int = qualid_of_ref int in let q_uint = qualid_of_ref uint in - Some ({ + let q_dec = qualid_of_ref dec in + let int_ty = { int = unsafe_locate_ind q_int; uint = unsafe_locate_ind q_uint; - }, mkRefC q_int, mkRefC q_uint) + } in + let dec_ty = { + int = int_ty; + decimal = unsafe_locate_ind q_dec; + } in + Some (int_ty, mkRefC q_int, mkRefC q_uint, dec_ty, mkRefC q_dec) else None let locate_int63 () = @@ -86,16 +93,16 @@ let type_error_to f ty = CErrors.user_err (pr_qualid f ++ str " should go from Decimal.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") + fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first).") let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ - str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") + str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first).") let vernac_numeral_notation env sigma local ty f g scope opts = - let int_ty = locate_int () in + let dec_ty = locate_decimal () in let z_pos_ty = locate_z () in let int63_ty = locate_int63 () in let tyc = Smartlocate.global_inductive_with_alias ty in @@ -110,11 +117,13 @@ let vernac_numeral_notation env sigma local ty f g scope opts = let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = - match int_ty with - | Some (int_ty, cint, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint cty) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + match dec_ty with + | Some (int_ty, cint, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + | Some (_, _, _, dec_ty, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal dec_ty, Direct + | Some (_, _, _, dec_ty, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal dec_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct @@ -127,11 +136,13 @@ let vernac_numeral_notation env sigma local ty f g scope opts = in (* Check the type of g *) let of_kind = - match int_ty with - | Some (int_ty, cint, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty cuint) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + match dec_ty with + | Some (int_ty, cint, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + | Some (_, _, _, dec_ty, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal dec_ty, Direct + | Some (_, _, _, dec_ty, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal dec_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index aac46338ea..7a23581768 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -3,7 +3,7 @@ (public_name coq.plugins.numeral_notation) (synopsis "Coq numeral notation plugin") (modules g_numeral numeral) - (libraries coq.plugins.ltac)) + (libraries coq.vernac)) (library (name string_notation_plugin) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index d90b7d754c..b9062dd16b 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -13,6 +13,7 @@ open Names open Globnames open Glob_term open Bigint +open Constrexpr (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -104,22 +105,76 @@ let r_modpath = MPfile (make_dir rdefinitions) let r_path = make_path rdefinitions "R" let glob_IZR = ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") - -let r_of_int ?loc z = - DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) +let glob_Rmult = ConstRef (Constant.make2 r_modpath @@ Label.make "Rmult") +let glob_Rdiv = ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") + +let binintdef = ["Coq";"ZArith";"BinIntDef"] +let z_modpath = MPdot (MPfile (make_dir binintdef), Label.make "Z") + +let glob_pow_pos = ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") + +let r_of_rawnum ?loc (sign,n) = + let n, f, e = NumTok.(n.int, n.frac, n.exp) in + let izr z = + DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z]) in + let rmult r r' = + DAst.make @@ GApp (DAst.make @@ GRef(glob_Rmult,None), [r; r']) in + let rdiv r r' = + DAst.make @@ GApp (DAst.make @@ GRef(glob_Rdiv,None), [r; r']) in + let pow10 e = + let ten = z_of_int ?loc (Bigint.of_int 10) in + let e = pos_of_bignat e in + DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [ten; e]) in + let n = + let n = Bigint.of_string (n ^ f) in + let n = match sign with SPlus -> n | SMinus -> Bigint.(neg n) in + izr (z_of_int ?loc n) in + let e = + let e = if e = "" then Bigint.zero else match e.[1] with + | '+' -> Bigint.of_string (String.sub e 2 (String.length e - 2)) + | '-' -> Bigint.(neg (of_string (String.sub e 2 (String.length e - 2)))) + | _ -> Bigint.of_string (String.sub e 1 (String.length e - 1)) in + Bigint.(sub e (of_int (String.length f))) in + if Bigint.is_strictly_pos e then rmult n (izr (pow10 e)) + else if Bigint.is_strictly_neg e then rdiv n (izr (pow10 (neg e))) + else n (* e = 0 *) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bigint_of_r c = match DAst.get c with +let rawnum_of_r c = match DAst.get c with | GApp (r, [a]) when is_gr r glob_IZR -> - bigint_of_z a + let n = bigint_of_z a in + let s, n = + if is_strictly_neg n then SMinus, neg n else SPlus, n in + s, NumTok.int (to_string n) + | GApp (md, [l; r]) when is_gr md glob_Rmult || is_gr md glob_Rdiv -> + begin match DAst.get l, DAst.get r with + | GApp (i, [l]), GApp (i', [r]) + when is_gr i glob_IZR && is_gr i' glob_IZR -> + begin match DAst.get r with + | GApp (p, [t; e]) when is_gr p glob_pow_pos -> + let t = bigint_of_z t in + if not (Bigint.(equal t (of_int 10))) then + raise Non_closed_number + else + let i = bigint_of_z l in + let e = bignat_of_pos e in + let s, i = if is_pos_or_zero i then SPlus, i else SMinus, neg i in + let i = Bigint.to_string i in + let se = if is_gr md glob_Rdiv then "-" else "" in + let e = se ^ Bigint.to_string e in + s, { NumTok.int = i; frac = ""; exp = e } + | _ -> raise Non_closed_number + end + | _ -> raise Non_closed_number + end | _ -> raise Non_closed_number let uninterp_r (AnyGlobConstr p) = try - Some (bigint_of_r p) + Some (rawnum_of_r p) with Non_closed_number -> None @@ -131,11 +186,11 @@ let at_declare_ml_module f x = let r_scope = "R_scope" let _ = - register_bignumeral_interpretation r_scope (r_of_int,uninterp_r); + register_rawnumeral_interpretation r_scope (r_of_rawnum,uninterp_r); at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = r_scope; pt_interp_info = Uid r_scope; pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); - pt_refs = [glob_IZR]; + pt_refs = [glob_IZR; glob_Rmult; glob_Rdiv]; pt_in_match = false } |