From cfbfe13f5b515ae2e3c6cdd97e2ccee03bc26e56 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Sun, 1 Feb 2009 00:54:40 +0100 Subject: Imported Upstream version 8.2~rc2+dfsg --- contrib/cc/cctac.ml | 27 +- contrib/dp/dp_gappa.ml | 6 +- contrib/dp/dp_zenon.mll | 4 +- contrib/extraction/common.ml | 610 ++-- contrib/extraction/common.mli | 20 +- contrib/extraction/extract_env.ml | 287 +- contrib/extraction/extraction.ml | 26 +- contrib/extraction/g_extraction.ml4 | 23 + contrib/extraction/haskell.ml | 9 +- contrib/extraction/modutil.ml | 76 +- contrib/extraction/modutil.mli | 16 +- contrib/extraction/ocaml.ml | 142 +- contrib/extraction/scheme.ml | 4 +- contrib/extraction/table.ml | 158 +- contrib/extraction/table.mli | 14 +- contrib/firstorder/rules.ml | 4 +- contrib/fourier/Fourier.v | 8 +- contrib/fourier/fourier.ml | 4 +- contrib/funind/functional_principles_proofs.ml | 23 +- contrib/funind/functional_principles_types.ml | 32 +- contrib/funind/g_indfun.ml4 | 125 +- contrib/funind/indfun.ml | 4 +- contrib/funind/indfun_common.ml | 7 +- contrib/funind/invfun.ml | 8 +- contrib/funind/merge.ml | 4 +- contrib/funind/rawterm_to_relation.ml | 16 +- contrib/funind/recdef.ml | 8 +- contrib/interface/ascent.mli | 2 +- contrib/interface/blast.ml | 28 +- contrib/interface/centaur.ml4 | 22 +- contrib/interface/dad.ml | 2 +- contrib/interface/depends.ml | 6 +- contrib/interface/name_to_ast.ml | 8 +- contrib/interface/parse.ml | 4 +- contrib/interface/paths.ml | 2 +- contrib/interface/pbp.ml | 2 +- contrib/interface/showproof.ml | 3 +- contrib/interface/vtp.ml | 2 +- contrib/interface/xlate.ml | 114 +- contrib/jprover/README | 76 - contrib/jprover/jall.ml | 4599 ------------------------ contrib/jprover/jall.mli | 339 -- contrib/jprover/jlogic.ml | 106 - contrib/jprover/jlogic.mli | 40 - contrib/jprover/jprover.ml4 | 554 --- contrib/jprover/jterm.ml | 872 ----- contrib/jprover/jterm.mli | 110 - contrib/jprover/jtunify.ml | 507 --- contrib/jprover/jtunify.mli | 35 - contrib/jprover/opname.ml | 90 - contrib/jprover/opname.mli | 15 - contrib/micromega/coq_micromega.ml | 2 +- contrib/omega/OmegaLemmas.v | 43 +- contrib/omega/coq_omega.ml | 47 +- contrib/ring/ring.ml | 28 +- contrib/setoid_ring/Ring_base.v | 1 - contrib/setoid_ring/Ring_tac.v | 1 - contrib/setoid_ring/newring.ml4 | 11 +- contrib/subtac/equations.ml4 | 1149 ++++++ contrib/subtac/eterm.ml | 121 +- contrib/subtac/eterm.mli | 22 +- contrib/subtac/g_subtac.ml4 | 16 +- contrib/subtac/subtac.ml | 38 +- contrib/subtac/subtac_cases.ml | 4 +- contrib/subtac/subtac_classes.ml | 159 +- contrib/subtac/subtac_classes.mli | 10 +- contrib/subtac/subtac_coercion.ml | 59 +- contrib/subtac/subtac_coercion.mli | 3 + contrib/subtac/subtac_command.ml | 6 +- contrib/subtac/subtac_obligations.ml | 246 +- contrib/subtac/subtac_obligations.mli | 19 +- contrib/subtac/subtac_pretyping.ml | 4 +- contrib/subtac/subtac_pretyping_F.ml | 23 +- contrib/subtac/subtac_utils.ml | 7 +- contrib/subtac/subtac_utils.mli | 3 +- contrib/xml/cic2Xml.ml | 2 +- contrib/xml/cic2acic.ml | 10 +- contrib/xml/proofTree2Xml.ml4 | 4 +- contrib/xml/xmlcommand.ml | 29 +- 79 files changed, 2660 insertions(+), 8610 deletions(-) delete mode 100644 contrib/jprover/README delete mode 100644 contrib/jprover/jall.ml delete mode 100644 contrib/jprover/jall.mli delete mode 100644 contrib/jprover/jlogic.ml delete mode 100644 contrib/jprover/jlogic.mli delete mode 100644 contrib/jprover/jprover.ml4 delete mode 100644 contrib/jprover/jterm.ml delete mode 100644 contrib/jprover/jterm.mli delete mode 100644 contrib/jprover/jtunify.ml delete mode 100644 contrib/jprover/jtunify.mli delete mode 100644 contrib/jprover/opname.ml delete mode 100644 contrib/jprover/opname.mli create mode 100644 contrib/subtac/equations.ml4 (limited to 'contrib') diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml index 871d7521..00cbbeee 100644 --- a/contrib/cc/cctac.ml +++ b/contrib/cc/cctac.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: cctac.ml 10670 2008-03-14 19:30:48Z letouzey $ *) +(* $Id: cctac.ml 11671 2008-12-12 12:43:03Z herbelin $ *) (* This file is the interface between the c-c algorithm and Coq *) @@ -48,10 +48,6 @@ let _eq = constant ["Init";"Logic"] "eq" let _False = constant ["Init";"Logic"] "False" -(* decompose member of equality in an applicative format *) - -let sf_of env sigma c = family_of_sort (destSort (type_of env sigma c)) - let whd env= let infos=Closure.create_clos_infos Closure.betaiotazeta env in (fun t -> Closure.whd_val infos (Closure.inject t)) @@ -60,6 +56,10 @@ let whd_delta env= let infos=Closure.create_clos_infos Closure.betadeltaiota env in (fun t -> Closure.whd_val infos (Closure.inject t)) +(* decompose member of equality in an applicative format *) + +let sf_of env sigma c = family_of_sort (destSort (whd_delta env (type_of env sigma c))) + let rec decompose_term env sigma t= match kind_of_term (whd env t) with App (f,args)-> @@ -317,7 +317,7 @@ let refute_tac c t1 t2 p gls = [|intype;tt1;tt2|]) in let hid=pf_get_new_id (id_of_string "Heq") gls in let false_t=mkApp (c,[|mkVar hid|]) in - tclTHENS (true_cut (Name hid) neweq) + tclTHENS (assert_tac (Name hid) neweq) [proof_tac p; simplest_elim false_t] gls let convert_to_goal_tac c t1 t2 p gls = @@ -329,14 +329,14 @@ let convert_to_goal_tac c t1 t2 p gls = let identity=mkLambda (Name x,sort,mkRel 1) in let endt=mkApp (Lazy.force _eq_rect, [|sort;tt1;identity;c;tt2;mkVar e|]) in - tclTHENS (true_cut (Name e) neweq) + tclTHENS (assert_tac (Name e) neweq) [proof_tac p;exact_check endt] gls let convert_to_hyp_tac c1 t1 c2 t2 p gls = let tt2=constr_of_term t2 in let h=pf_get_new_id (id_of_string "H") gls in let false_t=mkApp (c2,[|mkVar h|]) in - tclTHENS (true_cut (Name h) tt2) + tclTHENS (assert_tac (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] gls @@ -358,7 +358,7 @@ let discriminate_tac cstr p gls = let endt=mkApp (Lazy.force _eq_rect, [|outtype;trivial;pred;identity;concl;injt|]) in let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in - tclTHENS (true_cut (Name hid) neweq) + tclTHENS (assert_tac (Name hid) neweq) [proof_tac p;exact_check endt] gls (* wrap everything *) @@ -431,6 +431,12 @@ let congruence_tac depth l = (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) cc_fail +(* Beware: reflexivity = constructor 1 = apply refl_equal + might be slow now, let's rather do something equivalent + to a "simple apply refl_equal" *) + +let simple_reflexivity () = apply (Lazy.force _refl_equal) + (* The [f_equal] tactic. It mimics the use of lemmas [f_equal], [f_equal2], etc. @@ -442,7 +448,8 @@ let f_equal gl = let cut_eq c1 c2 = let ty = refresh_universes (pf_type_of gl c1) in tclTHENTRY - (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) reflexivity + (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) + (simple_reflexivity ()) in try match kind_of_term (pf_concl gl) with | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> diff --git a/contrib/dp/dp_gappa.ml b/contrib/dp/dp_gappa.ml index 70439a97..9c035aa8 100644 --- a/contrib/dp/dp_gappa.ml +++ b/contrib/dp/dp_gappa.ml @@ -153,18 +153,18 @@ let call_gappa hl p = let gappa_out2 = temp_file "gappa2" in patch_gappa_proof gappa_out gappa_out2; remove_file gappa_out; - let cmd = sprintf "%s/coqc %s" Coq_config.bindir gappa_out2 in + let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out2 in let out = Sys.command cmd in if out <> 0 then raise GappaProofFailed; let gappa_out3 = temp_file "gappa3" in let c = open_out gappa_out3 in let gappa2 = Filename.chop_suffix (Filename.basename gappa_out2) ".v" in Printf.fprintf c - "Require \"%s\". Set Printing Depth 9999999. Print %s.proof." + "Require \"%s\". Set Printing Depth 999999. Print %s.proof." (Filename.chop_suffix gappa_out2 ".v") gappa2; close_out c; let lambda = temp_file "gappa_lambda" in - let cmd = sprintf "%s/coqc %s > %s" Coq_config.bindir gappa_out3 lambda in + let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out3 ^ " > " ^ lambda in let out = Sys.command cmd in if out <> 0 then raise GappaProofFailed; remove_file gappa_out2; remove_file gappa_out3; diff --git a/contrib/dp/dp_zenon.mll b/contrib/dp/dp_zenon.mll index 2fc2a5f4..e15e280d 100644 --- a/contrib/dp/dp_zenon.mll +++ b/contrib/dp/dp_zenon.mll @@ -154,7 +154,7 @@ and read_main_proof = parse let s = Coq.fun_def_axiom f vars t in if !debug then Format.eprintf "axiom fun def = %s@." s; let c = constr_of_string gl s in - assert_tac true (Name (id_of_string id)) c gl) + assert_tac (Name (id_of_string id)) c gl) [tclTHEN intros reflexivity; tclIDTAC] let exact_string s gl = @@ -165,7 +165,7 @@ and read_main_proof = parse let interp_lemma l gl = let ty = constr_of_string gl l.l_type in tclTHENS - (assert_tac true (Name (id_of_string l.l_id)) ty) + (assert_tac (Name (id_of_string l.l_id)) ty) [exact_string l.l_proof; tclIDTAC] gl in diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml index 5ad4a288..02173c1f 100644 --- a/contrib/extraction/common.ml +++ b/contrib/extraction/common.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.ml 10596 2008-02-27 15:30:11Z letouzey $ i*) +(*i $Id: common.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) open Pp open Util @@ -60,14 +60,14 @@ let unquote s = let s = String.copy s in for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; s - -let rec dottify = function - | [] -> assert false - | [s] -> unquote s - | s::[""] -> unquote s - | s::l -> (dottify l)^"."^(unquote s) -(*s Uppercase/lowercase renamings. *) +let rec dottify = function + | [] -> assert false + | [s] -> s + | s::[""] -> s + | s::l -> (dottify l)^"."^s + +(*s Uppercase/lowercase renamings. *) let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false @@ -75,9 +75,15 @@ let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) let uppercase_id id = id_of_string (String.capitalize (string_of_id id)) -(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *) -let pr_upper_id id = str (String.capitalize (string_of_id id)) +type kind = Term | Type | Cons | Mod + +let upperkind = function + | Type -> lang () = Haskell + | Term -> false + | Cons | Mod -> true +let kindcase_id k id = + if upperkind k then uppercase_id id else lowercase_id id (*s de Bruijn environments for programs *) @@ -122,111 +128,109 @@ let get_db_name n (db,_) = (*s Tables of global renamings *) -let keywords = ref Idset.empty -let set_keywords kws = keywords := kws +let register_cleanup, do_cleanup = + let funs = ref [] in + (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs) -let global_ids = ref Idset.empty -let add_global_ids s = global_ids := Idset.add s !global_ids -let global_ids_list () = Idset.elements !global_ids +type phase = Pre | Impl | Intf -let empty_env () = [], !global_ids +let set_phase, get_phase = + let ph = ref Impl in ((:=) ph), (fun () -> !ph) -let mktable () = - let h = Hashtbl.create 97 in - (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) +let set_keywords, get_keywords = + let k = ref Idset.empty in + ((:=) k), (fun () -> !k) -let mkset () = - let h = Hashtbl.create 97 in - (fun x -> Hashtbl.add h x ()), (Hashtbl.mem h), (fun () -> Hashtbl.clear h) +let add_global_ids, get_global_ids = + let ids = ref Idset.empty in + register_cleanup (fun () -> ids := get_keywords ()); + let add s = ids := Idset.add s !ids + and get () = !ids + in (add,get) -let mktriset () = +let empty_env () = [], get_global_ids () + +let mktable autoclean = let h = Hashtbl.create 97 in - (fun x y z -> Hashtbl.add h (x,y,z) ()), - (fun x y z -> Hashtbl.mem h (x,y,z)), - (fun () -> Hashtbl.clear h) + if autoclean then register_cleanup (fun () -> Hashtbl.clear h); + (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) -(* For each [global_reference], this table will contain the different parts - of its renaming, in [string list] form. *) -let add_renaming, get_renaming, clear_renaming = mktable () +(* A table recording objects in the first level of all MPfile *) -(* Idem for [module_path]. *) -let add_mp_renaming, get_mp_renaming, clear_mp_renaming = mktable () +let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = + mktable false -(* A table for function modfstlev_rename *) -let add_modfstlev, get_modfstlev, clear_modfstlev = mktable () +(*s The list of external modules that will be opened initially *) -(* A set of all external objects that will have to be fully qualified *) -let add_static_clash, static_clash, clear_static_clash = mkset () +let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear = + let m = ref MPset.empty in + let add mp = m:=MPset.add mp !m + and mem mp = MPset.mem mp !m + and list () = MPset.elements !m + and clear () = m:=MPset.empty + in + register_cleanup clear; + (add,mem,list,clear) -(* Two tables of triplets [kind * module_path * string]. The first one - will record the first level of all MPfile, not only the current one. - The second table will contains local renamings. *) +(*s table indicating the visible horizon at a precise moment, + i.e. the stack of structures we are inside. -type kind = Term | Type | Cons | Mod + - The sequence of [mp] parts should have the following form: + [X.Y; X; A.B.C; A.B; A; ...], i.e. each addition should either + be a [MPdot] over the last entry, or something new, mainly + [MPself], or [MPfile] at the beginning. -let add_ext_mpmem, ext_mpmem, clear_ext_mpmem = mktriset () -let add_loc_mpmem, loc_mpmem, clear_loc_mpmem = mktriset () - -(* The list of external modules that will be opened initially *) -let add_mpfiles, mem_mpfiles, list_mpfiles, clear_mpfiles = - let m = ref MPset.empty in - (fun mp -> m:= MPset.add mp !m), - (fun mp -> MPset.mem mp !m), - (fun () -> MPset.elements !m), - (fun () -> m:= MPset.empty) - -(*s table containing the visible horizon at a precise moment *) - -let visible = ref ([] : module_path list) -let pop_visible () = visible := List.tl !visible -let push_visible mp = visible := mp :: !visible -let top_visible_mp () = List.hd !visible - -(*s substitutions for printing signatures *) - -let substs = ref empty_subst -let add_subst msid mp = substs := add_msid msid mp !substs -let subst_mp mp = subst_mp !substs mp -let subst_kn kn = subst_kn !substs kn -let subst_con c = fst (subst_con !substs c) -let subst_ref = function - | ConstRef con -> ConstRef (subst_con con) - | IndRef (kn,i) -> IndRef (subst_kn kn,i) - | ConstructRef ((kn,i),j) -> ConstructRef ((subst_kn kn,i),j) - | _ -> assert false - - -let duplicate_index = ref 0 -let to_duplicate = ref Gmap.empty -let add_duplicate mp l = - incr duplicate_index; - let ren = "Coq__" ^ string_of_int (!duplicate_index) in - to_duplicate := Gmap.add (mp,l) ren !to_duplicate -let check_duplicate mp l = - let mp' = subst_mp mp in - Gmap.find (mp',l) !to_duplicate - -type reset_kind = OnlyLocal | AllButExternal | Everything - -let reset_allbutext () = - clear_loc_mpmem (); - global_ids := !keywords; - clear_renaming (); - clear_mp_renaming (); - clear_modfstlev (); - clear_static_clash (); - clear_mpfiles (); - duplicate_index := 0; - to_duplicate := Gmap.empty; - visible := []; - substs := empty_subst - -let reset_everything () = reset_allbutext (); clear_ext_mpmem () - -let reset_renaming_tables = function - | OnlyLocal -> clear_loc_mpmem () - | AllButExternal -> reset_allbutext () - | Everything -> reset_everything () + - The [content] part is used to recoard all the names already + seen at this level. + + - The [subst] part is here mainly for printing signature + (in which names are still short, i.e. relative to a [msid]). +*) + +type visible_layer = { mp : module_path; + content : ((kind*string),unit) Hashtbl.t } + +let pop_visible, push_visible, get_visible, subst_mp = + let vis = ref [] and sub = ref [empty_subst] in + register_cleanup (fun () -> vis := []; sub := [empty_subst]); + let pop () = + let v = List.hd !vis in + (* we save the 1st-level-content of MPfile for later use *) + if get_phase () = Impl && modular () && is_modfile v.mp + then add_mpfiles_content v.mp v.content; + vis := List.tl !vis; + sub := List.tl !sub + and push mp o = + vis := { mp = mp; content = Hashtbl.create 97 } :: !vis; + let s = List.hd !sub in + let s = match o with None -> s | Some msid -> add_msid msid mp s in + sub := s :: !sub + and get () = !vis + and subst mp = subst_mp (List.hd !sub) mp + in (pop,push,get,subst) + +let get_visible_mps () = List.map (function v -> v.mp) (get_visible ()) +let top_visible () = match get_visible () with [] -> assert false | v::_ -> v +let top_visible_mp () = (top_visible ()).mp +let add_visible ks = Hashtbl.add (top_visible ()).content ks () + +(* table of local module wrappers used to provide non-ambiguous names *) + +let add_duplicate, check_duplicate = + let index = ref 0 and dups = ref Gmap.empty in + register_cleanup (fun () -> index := 0; dups := Gmap.empty); + let add mp l = + incr index; + let ren = "Coq__" ^ string_of_int (!index) in + dups := Gmap.add (mp,l) ren !dups + and check mp l = Gmap.find (subst_mp mp, l) !dups + in (add,check) + +type reset_kind = AllButExternal | Everything + +let reset_renaming_tables flag = + do_cleanup (); + if flag = Everything then clear_mpfiles_content () (*S Renaming functions *) @@ -235,248 +239,200 @@ let reset_renaming_tables = function with previous [Coq_id] variable, these prefixes are duplicated if already existing. *) -let modular_rename up id = +let modular_rename k id = let s = string_of_id id in - let prefix = if up then "Coq_" else "coq_" in - let check = if up then is_upper else is_lower in - if not (check s) || - (Idset.mem id !keywords) || - (String.length s >= 4 && String.sub s 0 4 = prefix) + let prefix,is_ok = + if upperkind k then "Coq_",is_upper else "coq_",is_lower + in + if not (is_ok s) || + (Idset.mem id (get_keywords ())) || + (String.length s >= 4 && String.sub s 0 4 = prefix) then prefix ^ s else s -(*s [record_contents_fstlev] finds the names of the first-level objects - exported by the ground-level modules in [struc]. *) - -let rec record_contents_fstlev struc = - let upper_type = (lang () = Haskell) in - let addtyp mp id = add_ext_mpmem Type mp (modular_rename upper_type id) in - let addcons mp id = add_ext_mpmem Cons mp (modular_rename true id) in - let addterm mp id = add_ext_mpmem Term mp (modular_rename false id) in - let addmod mp id = add_ext_mpmem Mod mp (modular_rename true id) in - let addfix mp r = - add_ext_mpmem Term mp (modular_rename false (id_of_global r)) - in - let f mp = function - | (l,SEdecl (Dind (_,ind))) -> - Array.iter - (fun ip -> - addtyp mp ip.ip_typename; Array.iter (addcons mp) ip.ip_consnames) - ind.ind_packets - | (l,SEdecl (Dtype _)) -> addtyp mp (id_of_label l) - | (l,SEdecl (Dterm _)) -> addterm mp (id_of_label l) - | (l,SEdecl (Dfix (rv,_,_))) -> Array.iter (addfix mp) rv - | (l,SEmodule _) -> addmod mp (id_of_label l) - | (l,SEmodtype _) -> addmod mp (id_of_label l) - in - List.iter (fun (mp,sel) -> List.iter (f mp) sel) struc - (*s For monolithic extraction, first-level modules might have to be renamed with unique numbers *) -let modfstlev_rename l = - let coqid = id_of_string "Coq" in - let id = id_of_label l in - try - let coqset = get_modfstlev id in - let nextcoq = next_ident_away coqid coqset in - add_modfstlev id (nextcoq::coqset); - (string_of_id nextcoq)^"_"^(string_of_id id) - with Not_found -> - let s = string_of_id id in - if is_lower s || begins_with_CoqXX s then - (add_modfstlev id [coqid]; "Coq_"^s) - else - (add_modfstlev id []; s) - - -(*s Creating renaming for a [module_path] *) - -let rec mp_create_renaming mp = - try get_mp_renaming mp - with Not_found -> - let ren = match mp with - | _ when not (modular ()) && at_toplevel mp -> [""] - | MPdot (mp,l) -> - let lmp = mp_create_renaming mp in - if lmp = [""] then (modfstlev_rename l)::lmp - else (modular_rename true (id_of_label l))::lmp - | MPself msid -> [modular_rename true (id_of_msid msid)] - | MPbound mbid -> [modular_rename true (id_of_mbid mbid)] - | MPfile _ when not (modular ()) -> assert false - | MPfile _ -> [string_of_modfile mp] - in add_mp_renaming mp ren; ren - -(* [clash mp0 s mpl] checks if [mp0-s] can be printed as [s] when - [mpl] is the context of visible modules. More precisely, we check if - there exists a [mp] in [mpl] that contains [s]. +let modfstlev_rename = + let add_prefixes,get_prefixes,_ = mktable true in + fun l -> + let coqid = id_of_string "Coq" in + let id = id_of_label l in + try + let coqset = get_prefixes id in + let nextcoq = next_ident_away coqid coqset in + add_prefixes id (nextcoq::coqset); + (string_of_id nextcoq)^"_"^(string_of_id id) + with Not_found -> + let s = string_of_id id in + if is_lower s || begins_with_CoqXX s then + (add_prefixes id [coqid]; "Coq_"^s) + else + (add_prefixes id []; s) + +(*s Creating renaming for a [module_path] : first, the real function ... *) + +let rec mp_renaming_fun mp = match mp with + | _ when not (modular ()) && at_toplevel mp -> [""] + | MPdot (mp,l) -> + let lmp = mp_renaming mp in + if lmp = [""] then (modfstlev_rename l)::lmp + else (modular_rename Mod (id_of_label l))::lmp + | MPself msid -> [modular_rename Mod (id_of_msid msid)] + | MPbound mbid -> [modular_rename Mod (id_of_mbid mbid)] + | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *) + | MPfile _ -> + assert (get_phase () = Pre); + let current_mpfile = (list_last (get_visible ())).mp in + if mp <> current_mpfile then mpfiles_add mp; + [string_of_modfile mp] + +(* ... and its version using a cache *) + +and mp_renaming = + let add,get,_ = mktable true in + fun x -> try get x with Not_found -> let y = mp_renaming_fun x in add x y; y + +(*s Renamings creation for a [global_reference]: we build its fully-qualified + name in a [string list] form (head is the short name). *) + +let ref_renaming_fun (k,r) = + let mp = subst_mp (modpath_of_r r) in + let l = mp_renaming mp in + let s = + if l = [""] (* this happens only at toplevel of the monolithic case *) + then + let globs = Idset.elements (get_global_ids ()) in + let id = next_ident_away (kindcase_id k (safe_id_of_global r)) globs in + string_of_id id + else modular_rename k (safe_id_of_global r) + in + add_global_ids (id_of_string s); + s::l + +(* Cached version of the last function *) + +let ref_renaming = + let add,get,_ = mktable true in + fun x -> try get x with Not_found -> let y = ref_renaming_fun x in add x y; y + +(* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k] + can be printed as [s] in the current context of visible + modules. More precisely, we check if there exists a + visible [mp] that contains [s]. The verification stops if we encounter [mp=mp0]. *) -let rec clash mem mp0 s = function +let rec clash mem mp0 ks = function | [] -> false | mp :: _ when mp = mp0 -> false - | mp :: mpl -> mem mp s || clash mem mp0 s mpl - -(*s Initial renamings creation, for modular extraction. *) - -let create_modular_renamings struc = - let current_module = fst (List.hd struc) in - let { typ = ty ; trm = tr ; cons = co } = struct_get_references_set struc - in - (* 1) creates renamings of objects *) - let add upper r = - let mp = modpath_of_r r in - let l = mp_create_renaming mp in - let s = modular_rename upper (id_of_global r) in - add_global_ids (id_of_string s); - add_renaming r (s::l); - begin try - let mp = modfile_of_mp mp in if mp <> current_module then add_mpfiles mp - with Not_found -> () - end; - in - Refset.iter (add (lang () = Haskell)) ty; - Refset.iter (add true) co; - Refset.iter (add false) tr; - - (* 2) determines the opened libraries. *) - let used_modules = list_mpfiles () in - let used_modules' = List.rev used_modules in - let str_list = List.map string_of_modfile used_modules' - in - let rec check_elsewhere mpl sl = match mpl, sl with - | [], [] -> [] - | mp::mpl, _::sl -> - if List.exists (ext_mpmem Mod mp) sl then - check_elsewhere mpl sl - else mp :: (check_elsewhere mpl sl) - | _ -> assert false - in - let opened_modules = check_elsewhere used_modules' str_list in - clear_mpfiles (); - List.iter add_mpfiles opened_modules; - - (* 3) determines the potential clashes *) - let needs_qualify k r = - let mp = modpath_of_r r in - if (is_modfile mp) && mp <> current_module && - (clash (ext_mpmem k) mp (List.hd (get_renaming r)) opened_modules) - then add_static_clash r - in - Refset.iter (needs_qualify Type) ty; - Refset.iter (needs_qualify Term) tr; - Refset.iter (needs_qualify Cons) co; - List.rev opened_modules - -(*s Initial renamings creation, for monolithic extraction. *) - -let create_mono_renamings struc = - let { typ = ty ; trm = tr ; cons = co } = struct_get_references_list struc in - let add upper r = - let mp = modpath_of_r r in - let l = mp_create_renaming mp in - let mycase = if upper then uppercase_id else lowercase_id in - let id = - if l = [""] then - next_ident_away (mycase (id_of_global r)) (global_ids_list ()) - else id_of_string (modular_rename upper (id_of_global r)) - in - add_global_ids id; - add_renaming r ((string_of_id id)::l) - in - List.iter (add (lang () = Haskell)) (List.rev ty); - List.iter (add false) (List.rev tr); - List.iter (add true) (List.rev co); - [] - -let create_renamings struc = - if modular () then create_modular_renamings struc - else create_mono_renamings struc - - + | mp :: _ when mem mp ks -> true + | _ :: mpl -> clash mem mp0 ks mpl + +let mpfiles_clash mp0 ks = + clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks + (List.rev (mpfiles_list ())) + +let visible_clash mp0 ks = + let rec clash = function + | [] -> false + | v :: _ when v.mp = mp0 -> false + | v :: _ when Hashtbl.mem v.content ks -> true + | _ :: vis -> clash vis + in clash (get_visible ()) + +(* After the 1st pass, we can decide which modules will be opened initially *) + +let opened_libraries () = + if not (modular ()) then [] + else + let used = mpfiles_list () in + let rec check_elsewhere avoid = function + | [] -> [] + | mp :: mpl -> + let clash s = Hashtbl.mem (get_mpfiles_content mp) (Mod,s) in + if List.exists clash avoid + then check_elsewhere avoid mpl + else mp :: check_elsewhere (string_of_modfile mp :: avoid) mpl + in + let opened = check_elsewhere [] used in + mpfiles_clear (); + List.iter mpfiles_add opened; + opened + (*s On-the-fly qualification issues for both monolithic or modular extraction. *) -let pp_global k r = - let ls = get_renaming r in - assert (List.length ls > 1); - let s = List.hd ls in - let mp = modpath_of_r r in - if mp = top_visible_mp () then +(* First, a function that factorize the printing of both [global_reference] + and module names for ocaml. When [k=Mod] then [olab=None], otherwise it + contains the label of the reference to print. + Invariant: [List.length ls >= 2], simpler situations are handled elsewhere. *) + +let pp_gen k mp ls olab = + try (* what is the largest prefix of [mp] that belongs to [visible]? *) + let prefix = common_prefix_from_list mp (get_visible_mps ()) in + let delta = mp_length mp - mp_length prefix in + assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *) + let ls = list_firstn (delta + if k = Mod then 0 else 1) ls in + let s,ls' = list_sep_last ls in + (* Reference r / module path mp is of the form [.s.]. + Difficulty: in ocaml the prefix part cannot be used for + qualification (we are inside it) and the rest of the long + name may be hidden. + Solution: we duplicate the _definition_ of r / mp in a Coq__XXX module *) + let k' = if ls' = [] then k else Mod in + if visible_clash prefix (k',s) then + let front = if ls' = [] && k <> Mod then [s] else ls' in + let lab = (* label associated with s *) + if delta = 0 && k <> Mod then Option.get olab + else get_nth_label_mp delta mp + in + try dottify (front @ [check_duplicate prefix lab]) + with Not_found -> + assert (get_phase () = Pre); (* otherwise it's too late *) + add_duplicate prefix lab; dottify ls + else dottify ls + with Not_found -> + (* [mp] belongs to a closed module, not one of [visible]. *) + let base = base_mp mp in + let base_s,ls1 = list_sep_last ls in + let s,ls2 = list_sep_last ls1 in + (* [List.rev ls] is [base_s :: s :: List.rev ls2] *) + let k' = if ls2 = [] then k else Mod in + if modular () && (mpfiles_mem base) && + (not (mpfiles_clash base (k',s))) && + (not (visible_clash base (k',s))) + then (* Standard situation of an object in another file: *) + (* Thanks to the "open" of this file we remove its name *) + dottify ls1 + else if visible_clash base (Mod,base_s) then + error_module_clash base_s + else dottify ls + +let pp_global k r = + let ls = ref_renaming (k,r) in + assert (List.length ls > 1); + let s = List.hd ls in + let mp = subst_mp (modpath_of_r r) in + if mp = top_visible_mp () then (* simpliest situation: definition of r (or use in the same context) *) (* we update the visible environment *) - (add_loc_mpmem k mp s; unquote s) - else match lang () with + (add_visible (k,s); unquote s) + else match lang () with | Scheme -> unquote s (* no modular Scheme extraction... *) - | Haskell -> - (* for the moment we always qualify in modular Haskell *) - if modular () then dottify ls else s - | Ocaml -> - try (* has [mp] something in common with one of [!visible] ? *) - let prefix = common_prefix_from_list mp !visible in - let delta = mp_length mp - mp_length prefix in - let ls = list_firstn (delta+1) ls in - (* Difficulty: in ocaml we cannot qualify more than [ls], - but this (not-so-long) name can in fact be hidden. Solution: - duplication of the _definition_ of r in a Coq__XXX module *) - let s,ls' = list_sep_last ls in - let k' = if ls' = [] then k else Mod in - if clash (loc_mpmem k') prefix s !visible then - let front = if ls' = [] then [s] else ls' in - let l = get_nth_label delta r in - try dottify (front @ [check_duplicate prefix l]) - with Not_found -> add_duplicate prefix l; dottify ls - else dottify ls - with Not_found -> - (* [mp] belongs to a closed module, not one of [!visible]. *) - let base = base_mp mp in - let base_s,ls1 = list_sep_last ls in - let s,ls2 = list_sep_last ls1 in - let k' = if ls2 = [] then k else Mod in - if modular () && (mem_mpfiles base) && - not (static_clash r) && - (* k' = Mod can't clash in an opened module, see earlier check *) - not (clash (loc_mpmem k') base s !visible) - then (* Standard situation of an object in another file: *) - (* Thanks to the "open" of this file we remove its name *) - dottify ls1 - else if clash (loc_mpmem Mod) base base_s !visible then - error_module_clash base_s - else dottify ls - + | Haskell -> if modular () then dottify ls else s + (* for the moment we always qualify in modular Haskell... *) + | Ocaml -> pp_gen k mp ls (Some (label_of_r r)) + (* The next function is used only in Ocaml extraction...*) -let pp_module mp = - let ls = mp_create_renaming mp in - if List.length ls = 1 then dottify ls - else match mp with - | MPdot (mp0,_) when mp0 = top_visible_mp () -> +let pp_module mp = + let mp = subst_mp mp in + let ls = mp_renaming mp in + if List.length ls = 1 then dottify ls + else match mp with + | MPdot (mp0,_) when mp0 = top_visible_mp () -> (* simpliest situation: definition of mp (or use in the same context) *) (* we update the visible environment *) - let s = List.hd ls in - add_loc_mpmem Mod mp0 s; s - | _ -> - try (* has [mp] something in common with one of those in [!visible] ? *) - let prefix = common_prefix_from_list mp !visible in - assert (mp <> prefix); (* no use of mp as whole module from itself *) - let delta = mp_length mp - mp_length prefix in - let ls = list_firstn delta ls in - (* Difficulty: in ocaml we cannot qualify more than [ls], - but this (not-so-long) name can in fact be hidden. Solution: - duplication of the _definition_ of mp via a Coq__XXX module *) - let s,ls' = list_sep_last ls in - if clash (loc_mpmem Mod) prefix s !visible then - let l = get_nth_label_mp delta mp in - try dottify (ls' @ [check_duplicate prefix l]) - with Not_found -> add_duplicate prefix l; dottify ls - else dottify ls - with Not_found -> - (* [mp] belongs to a closed module, not one of [!visible]. *) - let base = base_mp mp in - let base_s,ls' = list_sep_last ls in - let s = fst (list_sep_last ls) in - if modular () && (mem_mpfiles base) && - not (clash (loc_mpmem Mod) base s !visible) - then dottify ls' - else if clash (loc_mpmem Mod) base base_s !visible then - error_module_clash base_s - else dottify ls + let s = List.hd ls in + add_visible (Mod,s); s + | _ -> pp_gen Mod mp ls None + diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli index 5cd26584..b7e70414 100644 --- a/contrib/extraction/common.mli +++ b/contrib/extraction/common.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) +(*i $Id: common.mli 11559 2008-11-07 22:03:34Z letouzey $ i*) open Names open Libnames @@ -24,11 +24,6 @@ val pr_binding : identifier list -> std_ppcmds val rename_id : identifier -> Idset.t -> identifier -val lowercase_id : identifier -> identifier -val uppercase_id : identifier -> identifier - -val pr_upper_id : identifier -> std_ppcmds - type env = identifier list * Idset.t val empty_env : unit -> env @@ -37,9 +32,12 @@ val rename_tvars: Idset.t -> identifier list -> identifier list val push_vars : identifier list -> env -> identifier list * env val get_db_name : int -> env -> identifier -val record_contents_fstlev : ml_structure -> unit +type phase = Pre | Impl | Intf -val create_renamings : ml_structure -> module_path list +val set_phase : phase -> unit +val get_phase : unit -> phase + +val opened_libraries : unit -> module_path list type kind = Term | Type | Cons | Mod @@ -47,14 +45,12 @@ val pp_global : kind -> global_reference -> string val pp_module : module_path -> string val top_visible_mp : unit -> module_path -val push_visible : module_path -> unit +val push_visible : module_path -> mod_self_id option -> unit val pop_visible : unit -> unit -val add_subst : mod_self_id -> module_path -> unit - val check_duplicate : module_path -> label -> string -type reset_kind = OnlyLocal | AllButExternal | Everything +type reset_kind = AllButExternal | Everything val reset_renaming_tables : reset_kind -> unit diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index 311b42c0..49a86200 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.ml 10794 2008-04-15 00:12:06Z letouzey $ i*) +(*i $Id: extract_env.ml 11846 2009-01-22 18:55:10Z letouzey $ i*) open Term open Declarations @@ -83,8 +83,8 @@ module type VISIT = sig end module Visit : VISIT = struct - (* Thanks to C.S.C, what used to be in a single KNset should now be split - into a KNset (for inductives and modules names) and a Cset for constants + (* What used to be in a single KNset should now be split into a KNset + (for inductives and modules names) and a Cset for constants (and still the remaining MPset) *) type must_visit = { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t } @@ -140,6 +140,30 @@ let factor_fix env l cb msb = labels, recd, msb'' end +let build_mb expr typ_opt = + { mod_expr = Some expr; + mod_type = typ_opt; + mod_constraints = Univ.Constraint.empty; + mod_alias = Mod_subst.empty_subst; + mod_retroknowledge = [] } + +let my_type_of_mb env mb = + match mb.mod_type with + | Some mtb -> mtb + | None -> Modops.eval_struct env (Option.get mb.mod_expr) + +(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. + To check with Elie. *) + +let env_for_mtb_with env mtb idl = + let msid,sig_b = match Modops.eval_struct env mtb with + | SEBstruct(msid,sig_b) -> msid,sig_b + | _ -> assert false + in + let l = label_of_id (List.hd idl) in + let before = fst (list_split_at (fun (l',_) -> l=l') sig_b) in + Modops.add_signature (MPself msid) before env + (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) @@ -151,7 +175,7 @@ let rec extract_sfb_spec env mp = function let specs = extract_sfb_spec env mp msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end - | (l,SFBmind cb) :: msig -> + | (l,SFBmind _) :: msig -> let kn = make_kn mp empty_dirpath l in let s = Sind (kn, extract_inductive env kn) in let specs = extract_sfb_spec env mp msig in @@ -159,45 +183,52 @@ let rec extract_sfb_spec env mp = function else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> let specs = extract_sfb_spec env mp msig in - let mtb = Modops.type_of_mb env mb in - let spec = extract_seb_spec env (mb.mod_type<>None) mtb in + let spec = extract_seb_spec env (my_type_of_mb env mb) in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> let specs = extract_sfb_spec env mp msig in - (l,Smodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: specs - | (l,SFBalias(mp1,_))::msig -> - extract_sfb_spec env mp - ((l,SFBmodule {mod_expr = Some (SEBident mp1); - mod_type = None; - mod_constraints = Univ.Constraint.empty; - mod_alias = Mod_subst.empty_subst; - mod_retroknowledge = []})::msig) + (l,Smodtype (extract_seb_spec env mtb.typ_expr)) :: specs + | (l,SFBalias(mp1,typ_opt,_))::msig -> + let mb = build_mb (SEBident mp1) typ_opt in + extract_sfb_spec env mp ((l,SFBmodule mb) :: msig) (* From [struct_expr_body] to specifications *) +(* Invariant: the [seb] given to [extract_seb_spec] should either come: + - from a [mod_type] or [type_expr] field + - from the output of [Modops.eval_struct]. + This way, any encountered [SEBident] should be a true module type. + For instance, [my_type_of_mb] ensures this invariant. +*) -and extract_seb_spec env truetype = function - | SEBident kn when truetype -> Visit.add_mp kn; MTident kn +and extract_seb_spec env = function + | SEBident mp -> Visit.add_mp mp; MTident mp | SEBwith(mtb',With_definition_body(idl,cb))-> - let mtb''= extract_seb_spec env truetype mtb' in - (match extract_with_type env cb with (* cb peut contenir des kn *) + let env' = env_for_mtb_with env mtb' idl in + let mtb''= extract_seb_spec env mtb' in + (match extract_with_type env' cb with (* cb peut contenir des kn *) | None -> mtb'' | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ))) - | SEBwith(mtb',With_module_body(idl,mp,_))-> + | SEBwith(mtb',With_module_body(idl,mp,_,_))-> Visit.add_mp mp; - MTwith(extract_seb_spec env truetype mtb', + MTwith(extract_seb_spec env mtb', ML_With_module(idl,mp)) +(* TODO: On pourrait peut-etre oter certaines eta-expansion, du genre: + | SEBfunctor(mbid,_,SEBapply(m,SEBident (MPbound mbid2),_)) + when mbid = mbid2 -> extract_seb_spec env m + (* faudrait alors ajouter un test de non-apparition de mbid dans mb *) +*) | SEBfunctor (mbid, mtb, mtb') -> let mp = MPbound mbid in let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MTfunsig (mbid, extract_seb_spec env true mtb.typ_expr, - extract_seb_spec env' truetype mtb') + MTfunsig (mbid, extract_seb_spec env mtb.typ_expr, + extract_seb_spec env' mtb') | SEBstruct (msid, msig) -> let mp = MPself msid in let env' = Modops.add_signature mp msig env in MTsig (msid, extract_sfb_spec env' mp msig) - | (SEBapply _|SEBident _ (*when not truetype*)) as mtb -> - extract_seb_spec env truetype (Modops.eval_struct env mtb) + | SEBapply _ as mtb -> + extract_seb_spec env (Modops.eval_struct env mtb) (* From a [structure_body] (i.e. a list of [structure_field_body]) @@ -248,19 +279,11 @@ let rec extract_sfb env mp all = function let ms = extract_sfb env mp all msb in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then - (l,SEmodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: ms - else ms - | (l,SFBalias (mp1,cst)) :: msb -> - let ms = extract_sfb env mp all msb in - let mp = MPdot (mp,l) in - if all || Visit.needed_mp mp then - (l,SEmodule (extract_module env mp true - {mod_expr = Some (SEBident mp1); - mod_type = None; - mod_constraints= Univ.Constraint.empty; - mod_alias = empty_subst; - mod_retroknowledge = []})) :: ms + (l,SEmodtype (extract_seb_spec env mtb.typ_expr)) :: ms else ms + | (l,SFBalias (mp1,typ_opt,_)) :: msb -> + let mb = build_mb (SEBident mp1) typ_opt in + extract_sfb env mp all ((l,SFBmodule mb) :: msb) (* From [struct_expr_body] to implementations *) @@ -274,7 +297,7 @@ and extract_seb env mpo all = function | SEBfunctor (mbid, mtb, meb) -> let mp = MPbound mbid in let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MEfunctor (mbid, extract_seb_spec env true mtb.typ_expr, + MEfunctor (mbid, extract_seb_spec env mtb.typ_expr, extract_seb env' None true meb) | SEBstruct (msid, msb) -> let mp,msb = match mpo with @@ -288,17 +311,8 @@ and extract_seb env mpo all = function and extract_module env mp all mb = (* [mb.mod_expr <> None ], since we look at modules from outside. *) (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *) - let meb = Option.get mb.mod_expr in - let mtb = match mb.mod_type with - | None -> Modops.eval_struct env meb - | Some mt -> mt - in - (* Because of the "with" construct, the module type can be [MTBsig] with *) - (* a msid different from the one of the module. Here is the patch. *) - (* PL 26/02/2008: is this still relevant ? - let mtb = replicate_msid meb mtb in *) - { ml_mod_expr = extract_seb env (Some mp) all meb; - ml_mod_type = extract_seb_spec env (mb.mod_type<>None) mtb } + { ml_mod_expr = extract_seb env (Some mp) all (Option.get mb.mod_expr); + ml_mod_type = extract_seb_spec env (my_type_of_mb env mb) } let unpack = function MEstruct (_,sel) -> sel | _ -> assert false @@ -345,28 +359,38 @@ let mono_filename f = (* Builds a suitable filename from a module id *) -let module_filename m = - let d = descr () in - let f = if d.capital_file then String.capitalize else String.uncapitalize in - let fn = f (string_of_id m) in - Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, m +let module_filename fc = + let d = descr () in + let fn = if d.capital_file then fc else String.uncapitalize fc + in + Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, id_of_string fc (*s Extraction of one decl to stdout. *) let print_one_decl struc mp decl = - let d = descr () in - reset_renaming_tables AllButExternal; - ignore (create_renamings struc); - push_visible mp; - msgnl (d.pp_decl decl); + let d = descr () in + reset_renaming_tables AllButExternal; + set_phase Pre; + ignore (d.pp_struct struc); + set_phase Impl; + push_visible mp None; + msgnl (d.pp_decl decl); pop_visible () (*s Extraction of a ml struct to a file. *) -let print_structure_to_file (fn,si,mo) struc = - let d = descr () in - reset_renaming_tables AllButExternal; - let used_modules = create_renamings struc in +let formatter dry file = + if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) + else match file with + | None -> !Pp_control.std_ft + | Some cout -> + let ft = Pp_control.with_output_to cout in + Option.iter (Format.pp_set_margin ft) (Pp_control.get_margin ()); + ft + +let print_structure_to_file (fn,si,mo) dry struc = + let d = descr () in + reset_renaming_tables AllButExternal; let unsafe_needs = { mldummy = struct_ast_search ((=) MLdummy) struc; tdummy = struct_type_search Mlutil.isDummy struc; @@ -375,40 +399,39 @@ let print_structure_to_file (fn,si,mo) struc = if lang () <> Haskell then false else struct_ast_search (function MLmagic _ -> true | _ -> false) struc } in - (* print the implementation *) - let cout = Option.map open_out fn in - let ft = match cout with - | None -> !Pp_control.std_ft - | Some cout -> Pp_control.with_output_to cout in - begin try - msg_with ft (d.preamble mo used_modules unsafe_needs); - if lang () = Ocaml then begin - (* for computing objects to duplicate *) - let devnull = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) in - msg_with devnull (d.pp_struct struc); - reset_renaming_tables OnlyLocal; - end; + (* First, a dry run, for computing objects to rename or duplicate *) + set_phase Pre; + let devnull = formatter true None in + msg_with devnull (d.pp_struct struc); + let opened = opened_libraries () in + (* Print the implementation *) + let cout = if dry then None else Option.map open_out fn in + let ft = formatter dry cout in + begin try + (* The real printing of the implementation *) + set_phase Impl; + msg_with ft (d.preamble mo opened unsafe_needs); msg_with ft (d.pp_struct struc); Option.iter close_out cout; with e -> Option.iter close_out cout; raise e end; - Option.iter info_file fn; - (* print the signature *) - Option.iter - (fun si -> + if not dry then Option.iter info_file fn; + (* Now, let's print the signature *) + Option.iter + (fun si -> let cout = open_out si in - let ft = Pp_control.with_output_to cout in - begin try - msg_with ft (d.sig_preamble mo used_modules unsafe_needs); - reset_renaming_tables OnlyLocal; + let ft = formatter false (Some cout) in + begin try + set_phase Intf; + msg_with ft (d.sig_preamble mo opened unsafe_needs); msg_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; with e -> close_out cout; raise e end; info_file si) - si + (if dry then None else si) (*********************************************) @@ -426,51 +449,56 @@ let init modular = reset (); if modular && lang () = Scheme then error_scheme () +(* From a list of [reference], let's retrieve whether they correspond + to modules or [global_reference]. Warn the user if both is possible. *) + +let rec locate_ref = function + | [] -> [],[] + | r::l -> + let q = snd (qualid_of_reference r) in + let mpo = try Some (Nametab.locate_module q) with Not_found -> None + and ro = try Some (Nametab.locate q) with Not_found -> None in + match mpo, ro with + | None, None -> Nametab.error_global_not_found q + | None, Some r -> let refs,mps = locate_ref l in r::refs,mps + | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps + | Some mp, Some r -> + warning_both_mod_and_cst q mp r; + let refs,mps = locate_ref l in refs,mp::mps (*s Recursive extraction in the Coq toplevel. The vernacular command is \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when extracting to a file with the command: \verb!Extraction "file"! [qualid1] ... [qualidn]. *) -let full_extraction f qualids = - init false; - let rec find = function - | [] -> [],[] - | q::l -> - let refs,mps = find l in - try - let mp = Nametab.locate_module (snd (qualid_of_reference q)) in - if is_modfile mp then error_MPfile_as_mod mp true; - refs,(mp::mps) - with Not_found -> (Nametab.global q)::refs, mps - in - let refs,mps = find qualids in - let struc = optimize_struct refs (mono_environment refs mps) in - warning_axioms (); - print_structure_to_file (mono_filename f) struc; +let full_extr f (refs,mps) = + init false; + List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps; + let struc = optimize_struct refs (mono_environment refs mps) in + warning_axioms (); + print_structure_to_file (mono_filename f) false struc; reset () +let full_extraction f lr = full_extr f (locate_ref lr) + (*s Simple extraction in the Coq toplevel. The vernacular command is \verb!Extraction! [qualid]. *) -let simple_extraction qid = - init false; - try - let mp = Nametab.locate_module (snd (qualid_of_reference qid)) in - if is_modfile mp then error_MPfile_as_mod mp true; - full_extraction None [qid] - with Not_found -> - let r = Nametab.global qid in - if is_custom r then - msgnl (str "User defined extraction:" ++ spc () ++ - str (find_custom r) ++ fnl ()) - else - let struc = optimize_struct [r] (mono_environment [r] []) in - let d = get_decl_in_structure r struc in - warning_axioms (); - print_one_decl struc (modpath_of_r r) d; - reset () +let simple_extraction r = match locate_ref [r] with + | ([], [mp]) as p -> full_extr None p + | [r],[] -> + init false; + if is_custom r then + msgnl (str "User defined extraction:" ++ spc () ++ + str (find_custom r) ++ fnl ()) + else + let struc = optimize_struct [r] (mono_environment [r] []) in + let d = get_decl_in_structure r struc in + warning_axioms (); + print_one_decl struc (modpath_of_r r) d; + reset () + | _ -> assert false (*s (Recursive) Extraction of a library. The vernacular command is @@ -489,19 +517,16 @@ let extraction_library is_rec m = if Visit.needed_mp mp then (mp, unpack (extract_seb env (Some mp) true meb)) :: l else l - in - let struc = List.fold_left select [] l in - let struc = optimize_struct [] struc in - warning_axioms (); - record_contents_fstlev struc; - let rec print = function - | [] -> () - | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l - | (MPfile dir, sel) as e :: l -> - let short_m = snd (split_dirpath dir) in - print_structure_to_file (module_filename short_m) [e]; - print l + in + let struc = List.fold_left select [] l in + let struc = optimize_struct [] struc in + warning_axioms (); + let print = function + | (MPfile dir as mp, sel) as e -> + let dry = not is_rec && dir <> dir_m in + let s = string_of_modfile mp in + print_structure_to_file (module_filename s) dry [e] | _ -> assert false - in - print struc; + in + List.iter print struc; reset () diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index fdc84a64..fa006c1c 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml 10497 2008-02-01 12:18:37Z soubiran $ i*) +(*i $Id: extraction.ml 11459 2008-10-16 16:29:07Z letouzey $ i*) (*i*) open Util @@ -876,19 +876,17 @@ let extract_constant_spec env kn cb = let t = snd (record_constant_type env kn (Some typ)) in Sval (r, type_expunge env t) -let extract_with_type env cb = - let typ = Typeops.type_of_constant_type env cb.const_type in - match flag_of_type env typ with - | (_ , Default) -> None - | (Logic, TypeScheme) ->Some ([],Tdummy Ktype) - | (Info, TypeScheme) -> - let s,vl = type_sign_vl env typ in - (match cb.const_body with - | None -> assert false - | Some body -> - let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) - in Some ( vl, t) ) +let extract_with_type env cb = + let typ = Typeops.type_of_constant_type env cb.const_type in + match flag_of_type env typ with + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + let body = Option.get cb.const_body in + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) in + Some (vl, t) + | _ -> None + let extract_inductive env kn = let ind = extract_ind env kn in diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4 index cb95808d..345cb307 100644 --- a/contrib/extraction/g_extraction.ml4 +++ b/contrib/extraction/g_extraction.ml4 @@ -27,7 +27,13 @@ END open Table open Extract_env +let pr_language = function + | Ocaml -> str "Ocaml" + | Haskell -> str "Haskell" + | Scheme -> str "Scheme" + VERNAC ARGUMENT EXTEND language +PRINTED BY pr_language | [ "Ocaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] @@ -83,6 +89,23 @@ VERNAC COMMAND EXTEND ResetExtractionInline -> [ reset_extraction_inline () ] END +VERNAC COMMAND EXTEND ExtractionBlacklist +(* Force Extraction to not use some filenames *) +| [ "Extraction" "Blacklist" ne_ident_list(l) ] + -> [ extraction_blacklist l ] +END + +VERNAC COMMAND EXTEND PrintExtractionBlacklist +| [ "Print" "Extraction" "Blacklist" ] + -> [ print_extraction_blacklist () ] +END + +VERNAC COMMAND EXTEND ResetExtractionBlacklist +| [ "Reset" "Extraction" "Blacklist" ] + -> [ reset_extraction_blacklist () ] +END + + (* Overriding of a Coq object by an ML one *) VERNAC COMMAND EXTEND ExtractionConstant | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index 0ef225c0..3f0366e6 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.ml 10233 2007-10-17 23:29:08Z letouzey $ i*) +(*i $Id: haskell.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) (*s Production of Haskell syntax. *) @@ -22,6 +22,9 @@ open Common (*s Haskell renaming issues. *) +let pr_lower_id id = str (String.uncapitalize (string_of_id id)) +let pr_upper_id id = str (String.capitalize (string_of_id id)) + let keywords = List.fold_right (fun s -> Idset.add (id_of_string s)) [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; @@ -62,8 +65,6 @@ let pp_abst = function prlist_with_sep (fun () -> (str " ")) pr_id l ++ str " ->" ++ spc ()) -let pr_lower_id id = pr_id (lowercase_id id) - (*s The pretty-printer for haskell syntax *) let pp_global k r = @@ -313,7 +314,7 @@ let pp_structure_elem = function let pp_struct = let pp_sel (mp,sel) = - push_visible mp; + push_visible mp None; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml index 0c906712..68adeb81 100644 --- a/contrib/extraction/modutil.ml +++ b/contrib/extraction/modutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.ml 11262 2008-07-24 20:59:29Z letouzey $ i*) +(*i $Id: modutil.ml 11602 2008-11-18 00:08:33Z letouzey $ i*) open Names open Declarations @@ -18,23 +18,9 @@ open Table open Mlutil open Mod_subst -(*S Functions upon modules missing in [Modops]. *) - -(*s Change a msid in a module type, to follow a module expr. - Because of the "with" construct, the module type of a module can be a - [MTBsig] with a msid different from the one of the module. *) - -let rec replicate_msid meb mtb = match meb,mtb with - | SEBfunctor (_, _, meb), SEBfunctor (mbid, mtb1, mtb2) -> - let mtb' = replicate_msid meb mtb2 in - if mtb' == mtb2 then mtb else SEBfunctor (mbid, mtb1, mtb') - | SEBstruct (msid, _), SEBstruct (msid1, msig) when msid <> msid1 -> - let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in - if msig' == msig then SEBstruct (msid, msig) else SEBstruct (msid, msig') - | _ -> mtb - (*S Functions upon ML modules. *) -let rec msid_of_mt = function + +let rec msid_of_mt = function | MTident mp -> begin match Modops.eval_struct (Global.env()) (SEBident mp) with | SEBstruct(msid,_) -> MPself msid @@ -42,12 +28,7 @@ let rec msid_of_mt = function end | MTwith(mt,_)-> msid_of_mt mt | _ -> anomaly "Extraction:the With operator isn't applied to a name" - -let make_mp_with mp idl = - let idl_rev = List.rev idl in - let idl' = List.rev (List.tl idl_rev) in - (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) - mp idl') + (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) @@ -57,13 +38,12 @@ let struct_iter do_decl do_spec s = | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> let mp_mt = msid_of_mt mt in - let mp = make_mp_with mp_mt idl in - let gr = ConstRef ( - (make_con mp empty_dirpath - (label_of_id ( - List.hd (List.rev idl))))) in - mt_iter mt;do_decl - (Dtype(gr,l,t)) + let l',idl' = list_sep_last idl in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' + in + let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in + mt_iter mt; do_decl (Dtype(r,l,t)) | MTwith (mt,_)->mt_iter mt | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function @@ -143,41 +123,6 @@ let spec_iter_references do_term do_cons do_type = function | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot | Sval (r,t) -> do_term r; type_iter_references do_type t -let struct_iter_references do_term do_cons do_type = - struct_iter - (decl_iter_references do_term do_cons do_type) - (spec_iter_references do_term do_cons do_type) - -(*s Get all references used in one [ml_structure], either in [list] or [set]. *) - -type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a } - -let struct_get_references empty add struc = - let o = { typ = empty ; trm = empty ; cons = empty } in - let do_type r = o.typ <- add r o.typ in - let do_term r = o.trm <- add r o.trm in - let do_cons r = o.cons <- add r o.cons in - struct_iter_references do_term do_cons do_type struc; o - -let struct_get_references_set = struct_get_references Refset.empty Refset.add - -module Orefset = struct - type t = { set : Refset.t ; list : global_reference list } - let empty = { set = Refset.empty ; list = [] } - let add r o = - if Refset.mem r o.set then o - else { set = Refset.add r o.set ; list = r :: o.list } - let set o = o.set - let list o = o.list -end - -let struct_get_references_list struc = - let o = struct_get_references Orefset.empty Orefset.add struc in - { typ = Orefset.list o.typ; - trm = Orefset.list o.trm; - cons = Orefset.list o.cons } - - (*s Searching occurrences of a particular term (no lifting done). *) exception Found @@ -411,6 +356,7 @@ let optimize_struct to_appear struc = let opt_struc = List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc in + let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in try if modular () then raise NoDepCheck; reset_needed (); diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli index 85d58a4b..e279261d 100644 --- a/contrib/extraction/modutil.mli +++ b/contrib/extraction/modutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.mli 10620 2008-03-05 10:54:41Z letouzey $ i*) +(*i $Id: modutil.mli 11602 2008-11-18 00:08:33Z letouzey $ i*) open Names open Declarations @@ -15,12 +15,6 @@ open Libnames open Miniml open Mod_subst -(*s Functions upon modules missing in [Modops]. *) - -(* Change a msid in a module type, to follow a module expr. *) - -val replicate_msid : struct_expr_body -> struct_expr_body -> struct_expr_body - (*s Functions upon ML modules. *) val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool @@ -30,15 +24,11 @@ type do_ref = global_reference -> unit val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit -val struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit - -type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a } - -val struct_get_references_set : ml_structure -> Refset.t kinds -val struct_get_references_list : ml_structure -> global_reference list kinds val signature_of_structure : ml_structure -> ml_signature +val msid_of_mt : ml_module_type -> module_path + val get_decl_in_structure : global_reference -> ml_structure -> ml_decl (* Some transformations of ML terms. [optimize_struct] simplify diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index 64c80a2a..0166d854 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.ml 10592 2008-02-27 14:16:07Z letouzey $ i*) +(*i $Id: ocaml.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) (*s Production of Ocaml syntax. *) @@ -25,22 +25,6 @@ open Declarations (*s Some utility functions. *) -let rec msid_of_mt = function - | MTident mp -> begin - match Modops.eval_struct (Global.env()) (SEBident mp) with - | SEBstruct(msid,_) -> MPself msid - | _ -> anomaly "Extraction:the With can't be applied to a funsig" - end - | MTwith(mt,_)-> msid_of_mt mt - | _ -> anomaly "Extraction:the With operator isn't applied to a name" - -let make_mp_with mp idl = - let idl_rev = List.rev idl in - let idl' = List.rev (List.tl idl_rev) in - (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) - mp idl') - - let pp_tvar id = let s = string_of_id id in if String.length s < 2 || s.[1]<>'\'' @@ -107,12 +91,18 @@ let sig_preamble _ used_modules usf = (*s The pretty-printer for Ocaml syntax*) -let pp_global k r = - if is_inline_custom r then str (find_custom r) +(* Beware of the side-effects of [pp_global] and [pp_modname]. + They are used to update table of content for modules. Many [let] + below should not be altered since they force evaluation order. +*) + +let pp_global k r = + if is_inline_custom r then str (find_custom r) else str (Common.pp_global k r) let pp_modname mp = str (Common.pp_module mp) + let is_infix r = is_inline_custom r && (let s = find_custom r in @@ -462,7 +452,7 @@ let pp_ind co kn ind = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in - let ip_equiv = ind.ind_equiv, 0 in + let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in if is_custom (IndRef ip) then pp (i+1) else begin @@ -607,52 +597,49 @@ and pp_module_type ol = function | MTident kn -> pp_modname kn | MTfunsig (mbid, mt, mt') -> - let name = pp_modname (MPbound mbid) in let typ = pp_module_type None mt in + let name = pp_modname (MPbound mbid) in let def = pp_module_type None mt' in str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MTsig (msid, sign) -> - let tvm = top_visible_mp () in - Option.iter (fun l -> add_subst msid (MPdot (tvm, l))) ol; - let mp = MPself msid in - push_visible mp; + let tvm = top_visible_mp () in + let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in + (* References in [sign] are in short form (relative to [msid]). + In push_visible, [msid-->mp] is added to the current subst. *) + push_visible mp (Some msid); let l = map_succeed pp_specif sign in pop_visible (); str "sig " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> - let l = rename_tvars keywords vl in - let ids = pp_parameters l in + let ids = pp_parameters (rename_tvars keywords vl) in let mp_mt = msid_of_mt mt in - let mp = make_mp_with mp_mt idl in - let gr = ConstRef ( - (make_con mp empty_dirpath - (label_of_id ( - List.hd (List.rev idl))))) in - push_visible mp_mt; - let s = pp_module_type None mt ++ - str " with type " ++ - pp_global Type gr ++ - ids in - pop_visible(); - s ++ str "=" ++ spc () ++ - pp_type false vl typ + let l,idl' = list_sep_last idl in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' + in + let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) + in + push_visible mp_mt None; + let s = + pp_module_type None mt ++ str " with type " ++ + pp_global Type r ++ ids + in + pop_visible(); + s ++ str "=" ++ spc () ++ pp_type false vl typ | MTwith(mt,ML_With_module(idl,mp)) -> - let mp_mt=msid_of_mt mt in - push_visible mp_mt; - let s = - pp_module_type None mt ++ - str " with module " ++ - (pp_modname - (List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) - mp_mt idl)) - ++ str " = " - in - pop_visible (); - s ++ (pp_modname mp) - - + let mp_mt = msid_of_mt mt in + let mp_w = + List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl + in + push_visible mp_mt None; + let s = + pp_module_type None mt ++ str " with module " ++ pp_modname mp_w + in + pop_visible (); + s ++ str " = " ++ pp_modname mp + let is_short = function MEident _ | MEapply _ -> true | _ -> false let rec pp_structure_elem = function @@ -664,10 +651,16 @@ let rec pp_structure_elem = function pp_alias_decl ren d with Not_found -> pp_decl d) | (l,SEmodule m) -> + let typ = + (* virtual printing of the type, in order to have a correct mli later*) + if Common.get_phase () = Pre then + str ": " ++ pp_module_type (Some l) m.ml_mod_type + else mt () + in let def = pp_module_expr (Some l) m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 - (str "module " ++ name ++ str " = " ++ + (str "module " ++ name ++ typ ++ str " = " ++ (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in @@ -694,33 +687,34 @@ and pp_module_expr ol = function | MEstruct (msid, sel) -> let tvm = top_visible_mp () in let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in - push_visible mp; + (* No need to update the subst with [Some msid] below : names are + already in long form (see [subst_structure] in [Extract_env]). *) + push_visible mp None; let l = map_succeed pp_structure_elem sel in pop_visible (); str "struct " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" -let pp_struct s = - let pp mp s = - push_visible mp; - let p = pp_structure_elem s ++ fnl2 () in - pop_visible (); p +let do_struct f s = + let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () in - prlist_strict - (fun (mp,sel) -> prlist_strict identity (map_succeed (pp mp) sel)) s - -let pp_signature s = - let pp mp s = - push_visible mp; - let p = pp_specif s ++ fnl2 () in - pop_visible (); p - in - prlist_strict - (fun (mp,sign) -> prlist_strict identity (map_succeed (pp mp) sign)) s + let ppl (mp,sel) = + push_visible mp None; + let p = prlist_strict pp sel in + (* for monolithic extraction, we try to simulate the unavailability + of [MPfile] in names by artificially nesting these [MPfile] *) + (if modular () then pop_visible ()); p + in + let p = prlist_strict ppl s in + (if not (modular ()) then repeat (List.length s) pop_visible ()); + p + +let pp_struct s = do_struct pp_structure_elem s + +let pp_signature s = do_struct pp_specif s -let pp_decl d = - try pp_decl d with Failure "empty phrase" -> mt () +let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () let ocaml_descr = { keywords = keywords; diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml index 600f64db..f4941a9c 100644 --- a/contrib/extraction/scheme.ml +++ b/contrib/extraction/scheme.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.ml 10233 2007-10-17 23:29:08Z letouzey $ i*) +(*i $Id: scheme.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) (*s Production of Scheme syntax. *) @@ -183,7 +183,7 @@ let pp_structure_elem = function let pp_struct = let pp_sel (mp,sel) = - push_visible mp; + push_visible mp None; let p = prlist_strict pp_structure_elem sel in pop_visible (); p in diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml index 10f669e1..c675a744 100644 --- a/contrib/extraction/table.ml +++ b/contrib/extraction/table.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.ml 11262 2008-07-24 20:59:29Z letouzey $ i*) +(*i $Id: table.ml 11844 2009-01-22 16:45:06Z letouzey $ i*) open Names open Term @@ -52,7 +52,7 @@ let is_modfile = function | MPfile _ -> true | _ -> false -let string_of_modfile = function +let raw_string_of_modfile = function | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) | _ -> assert false @@ -76,24 +76,15 @@ let rec prefixes_mp mp = match mp with | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') | _ -> MPset.singleton mp -let rec get_nth_label_mp n mp = match mp with - | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp +let rec get_nth_label_mp n = function + | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp | _ -> failwith "get_nth_label: not enough MPdot" -let get_nth_label n r = - if n=0 then label_of_r r else get_nth_label_mp n (modpath_of_r r) - -let rec common_prefix prefixes_mp1 mp2 = - if MPset.mem mp2 prefixes_mp1 then mp2 - else match mp2 with - | MPdot (mp,_) -> common_prefix prefixes_mp1 mp - | _ -> raise Not_found - let common_prefix_from_list mp0 mpl = - let prefixes_mp0 = prefixes_mp mp0 in + let prefixes = prefixes_mp mp0 in let rec f = function | [] -> raise Not_found - | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l + | mp :: l -> if MPset.mem mp prefixes then mp else f l in f mpl let rec parse_labels ll = function @@ -185,39 +176,39 @@ let modular_ref = ref false let set_modular b = modular_ref := b let modular () = !modular_ref -(*s Tables synchronization. *) - -let reset_tables () = - init_terms (); init_types (); init_inductives (); init_recursors (); - init_projs (); init_axioms () - (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. WARNING: for inductive objects, an extract_inductive must have been done before. *) -let id_of_global = function +let safe_id_of_global = function | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l | IndRef (kn,i) -> (snd (lookup_ind kn)).ind_packets.(i).ip_typename | ConstructRef ((kn,i),j) -> (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) | _ -> assert false -let pr_global r = - try Printer.pr_global r - with _ -> pr_id (id_of_global r) +let safe_pr_global r = + try Printer.pr_global r + with _ -> pr_id (safe_id_of_global r) (* idem, but with qualification, and only for constants. *) -let pr_long_global r = - try Printer.pr_global r +let safe_pr_long_global r = + try Printer.pr_global r with _ -> match r with - | ConstRef kn -> - let mp,_,l = repr_con kn in + | ConstRef kn -> + let mp,_,l = repr_con kn in str ((string_of_mp mp)^"."^(string_of_label l)) | _ -> assert false +let pr_long_mp mp = + let lid = repr_dirpath (Nametab.dir_of_mp mp) in + str (String.concat "." (List.map string_of_id (List.rev lid))) + +let pr_long_global ref = pr_sp (Nametab.sp_of_global ref) + (*S Warning and Error messages. *) let err s = errorlabstrm "Extraction" s @@ -229,7 +220,7 @@ let warning_axioms () = let s = if List.length info_axioms = 1 then "axiom" else "axioms" in msg_warning (str ("The following "^s^" must be realized in the extracted code:") - ++ hov 1 (spc () ++ prlist_with_sep spc pr_global info_axioms) + ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms) ++ str "." ++ fnl ()) end; let log_axioms = Refset.elements !log_axioms in @@ -239,15 +230,27 @@ let warning_axioms () = in msg_warning (str ("The following logical "^s^" encountered:") ++ - hov 1 (spc () ++ prlist_with_sep spc pr_global log_axioms ++ str ".\n") ++ + hov 1 + (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n") + ++ str "Having invalid logical axiom in the environment when extracting" ++ spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ fnl ()) end +let warning_both_mod_and_cst q mp r = + msg_warning + (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++ + str "do you mean module " ++ + pr_long_mp mp ++ + str " or object " ++ + pr_long_global r ++ str " ?" ++ fnl () ++ + str "First choice is assumed, for the second one please use " ++ + str "fully qualified name." ++ fnl ()) + let error_axiom_scheme r i = err (str "The type scheme axiom " ++ spc () ++ - pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ + safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ str " type variable(s).") let check_inside_module () = @@ -265,10 +268,10 @@ let check_inside_section () = str "Close it and try again.") let error_constant r = - err (pr_global r ++ str " is not a constant.") + err (safe_pr_global r ++ str " is not a constant.") let error_inductive r = - err (pr_global r ++ spc () ++ str "is not an inductive type.") + err (safe_pr_global r ++ spc () ++ str "is not an inductive type.") let error_nb_cons () = err (str "Not the right number of constructors.") @@ -284,21 +287,21 @@ let error_scheme () = err (str "No Scheme modular extraction available yet.") let error_not_visible r = - err (pr_global r ++ str " is not directly visible.\n" ++ + err (safe_pr_global r ++ str " is not directly visible.\n" ++ str "For example, it may be inside an applied functor." ++ str "Use Recursive Extraction to get the whole environment.") let error_MPfile_as_mod mp b = let s1 = if b then "asked" else "required" in let s2 = if b then "extract some objects of this module or\n" else "" in - err (str ("Extraction of file "^(string_of_modfile mp)^ + err (str ("Extraction of file "^(raw_string_of_modfile mp)^ ".v as a module is "^s1^".\n"^ "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) -let error_record r = - err (str "Record " ++ pr_global r ++ str " has an anonymous field." ++ fnl () ++ - str "To help extraction, please use an explicit name.") +let error_record r = + err (str "Record " ++ safe_pr_global r ++ str " has an anonymous field." ++ + fnl () ++ str "To help extraction, please use an explicit name.") let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then @@ -481,11 +484,11 @@ let print_extraction_inline () = (str "Extraction Inline:" ++ fnl () ++ Refset.fold (fun r p -> - (p ++ str " " ++ pr_long_global r ++ fnl ())) i' (mt ()) ++ + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ str "Extraction NoInline:" ++ fnl () ++ Refset.fold (fun r p -> - (p ++ str " " ++ pr_long_global r ++ fnl ())) n (mt ())) + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) (* Reset part *) @@ -498,6 +501,73 @@ let (reset_inline,_) = let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) +(*s Extraction Blacklist of filenames not to use while extracting *) + +let blacklist_table = ref Idset.empty + +let modfile_ids = ref [] +let modfile_mps = ref MPmap.empty + +let reset_modfile () = + modfile_ids := Idset.elements !blacklist_table; + modfile_mps := MPmap.empty + +let string_of_modfile mp = + try MPmap.find mp !modfile_mps + with Not_found -> + let id = id_of_string (raw_string_of_modfile mp) in + let id' = next_ident_away id !modfile_ids in + let s' = string_of_id id' in + modfile_ids := id' :: !modfile_ids; + modfile_mps := MPmap.add mp s' !modfile_mps; + s' + +let add_blacklist_entries l = + blacklist_table := + List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s))) + l !blacklist_table + +(* Registration of operations for rollback. *) + +let (blacklist_extraction,_) = + declare_object + {(default_object "Extraction Blacklist") with + cache_function = (fun (_,l) -> add_blacklist_entries l); + load_function = (fun _ (_,l) -> add_blacklist_entries l); + export_function = (fun x -> Some x); + classify_function = (fun (_,o) -> Libobject.Keep o); + subst_function = (fun (_,_,x) -> x) + } + +let _ = declare_summary "Extraction Blacklist" + { freeze_function = (fun () -> !blacklist_table); + unfreeze_function = ((:=) blacklist_table); + init_function = (fun () -> blacklist_table := Idset.empty); + survive_module = true; + survive_section = true } + +(* Grammar entries. *) + +let extraction_blacklist l = + let l = List.rev_map string_of_id l in + Lib.add_anonymous_leaf (blacklist_extraction l) + +(* Printing part *) + +let print_extraction_blacklist () = + msgnl + (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table)) + +(* Reset part *) + +let (reset_blacklist,_) = + declare_object + {(default_object "Reset Extraction Blacklist") with + cache_function = (fun (_,_)-> blacklist_table := Idset.empty); + load_function = (fun _ (_,_)-> blacklist_table := Idset.empty); + export_function = (fun x -> Some x)} + +let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) (*s Extract Constant/Inductive. *) @@ -575,3 +645,9 @@ let extract_inductive r (s,l) = | _ -> error_inductive g + +(*s Tables synchronization. *) + +let reset_tables () = + init_terms (); init_types (); init_inductives (); init_recursors (); + init_projs (); init_axioms (); reset_modfile () diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli index 4dbccd08..5ef7139e 100644 --- a/contrib/extraction/table.mli +++ b/contrib/extraction/table.mli @@ -6,20 +6,20 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.mli 11262 2008-07-24 20:59:29Z letouzey $ i*) +(*i $Id: table.mli 11844 2009-01-22 16:45:06Z letouzey $ i*) open Names open Libnames open Miniml open Declarations -val id_of_global : global_reference -> identifier -val pr_long_global : global_reference -> Pp.std_ppcmds - +val safe_id_of_global : global_reference -> identifier (*s Warning and Error messages. *) val warning_axioms : unit -> unit +val warning_both_mod_and_cst : + qualid -> module_path -> global_reference -> unit val error_axiom_scheme : global_reference -> int -> 'a val error_constant : global_reference -> 'a val error_inductive : global_reference -> 'a @@ -55,7 +55,6 @@ val modfile_of_mp : module_path -> module_path val common_prefix_from_list : module_path -> module_path list -> module_path val add_labels_mp : module_path -> label list -> module_path val get_nth_label_mp : int -> module_path -> label -val get_nth_label : int -> global_reference -> label val labels_of_ref : global_reference -> module_path * label list (*s Some table-related operations *) @@ -142,6 +141,11 @@ val extract_constant_inline : bool -> reference -> string list -> string -> unit val extract_inductive : reference -> string * string list -> unit +(*s Table of blacklisted filenames *) + +val extraction_blacklist : identifier list -> unit +val reset_extraction_blacklist : unit -> unit +val print_extraction_blacklist : unit -> unit diff --git a/contrib/firstorder/rules.ml b/contrib/firstorder/rules.ml index b8b56548..cc7b19e0 100644 --- a/contrib/firstorder/rules.ml +++ b/contrib/firstorder/rules.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.ml 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: rules.ml 11512 2008-10-27 12:28:36Z herbelin $ *) open Util open Names @@ -213,4 +213,4 @@ let normalize_evaluables= None->unfold_in_concl (Lazy.force defined_connectives) | Some ((_,id),_)-> unfold_in_hyp (Lazy.force defined_connectives) - ((Rawterm.all_occurrences_expr,id),Tacexpr.InHypTypeOnly)) + ((Rawterm.all_occurrences_expr,id),InHypTypeOnly)) diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v index 1a1a5055..024aa1c3 100644 --- a/contrib/fourier/Fourier.v +++ b/contrib/fourier/Fourier.v @@ -6,16 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier.v 9178 2006-09-26 11:18:22Z barras $ *) +(* $Id: Fourier.v 11672 2008-12-12 14:45:09Z herbelin $ *) (* "Fourier's method to solve linear inequations/equations systems.".*) -Declare ML Module "quote". -Declare ML Module "ring". -Declare ML Module "fourier". -Declare ML Module "fourierR". -Declare ML Module "field". - Require Export Fourier_util. Require Export LegacyField. Require Export DiscrR. diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml index ed804e94..195d8605 100644 --- a/contrib/fourier/fourier.ml +++ b/contrib/fourier/fourier.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: fourier.ml 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: fourier.ml 11671 2008-12-12 12:43:03Z herbelin $ *) (* Méthode d'élimination de Fourier *) (* Référence: @@ -202,4 +202,4 @@ let test2=[ deduce test2;; unsolvable test2;; -*) \ No newline at end of file +*) diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index bd335d30..9f3e412a 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -136,7 +136,7 @@ let change_hyp_with_using msg hyp_id t tac : tactic = fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS - ((* observe_tac msg *) (forward (Some (tclCOMPLETE tac)) (dummy_loc,Genarg.IntroIdentifier prov_id) t)) + ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) [tclTHENLIST [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); @@ -388,7 +388,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = in (* observe_tac "rec hyp " *) (tclTHENS - (assert_as true (dummy_loc, Genarg.IntroIdentifier rec_pte_id) t_x) + (assert_tac (Name rec_pte_id) t_x) [ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); (* observe_tac "prove rec hyp" *) @@ -571,7 +571,7 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id fun g -> let prov_hid = pf_get_new_id hid g in tclTHENLIST[ - forward None (dummy_loc,Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args)); + pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); thin [hid]; h_rename [prov_hid,hid] ] g @@ -1347,7 +1347,7 @@ let build_clause eqs = { Tacexpr.onhyps = Some (List.map - (fun id -> (Rawterm.all_occurrences_expr,id),Tacexpr.InHyp) + (fun id -> (Rawterm.all_occurrences_expr,id),InHyp) eqs ); Tacexpr.concl_occs = Rawterm.no_occurrences_expr @@ -1399,7 +1399,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = false (true,5) [Lazy.force refl_equal] - [Auto.Hint_db.empty false] + [Auto.Hint_db.empty empty_transparent_state false] ) ) ) @@ -1495,10 +1495,9 @@ let prove_principle_for_gen ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE (tclTHEN - (forward - (Some ((fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))) - (dummy_loc,Genarg.IntroIdentifier wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|]))) + (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded,[|input_type;relation|])) + (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) ( (* observe_tac *) (* "apply wf_thm" *) @@ -1559,10 +1558,10 @@ let prove_principle_for_gen (List.rev_map (fun (na,_,_) -> Nameops.out_name na) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); - (* observe_tac "" *) (forward - (Some (prove_rec_arg_acc)) - (dummy_loc,Genarg.IntroIdentifier acc_rec_arg_id) + (* observe_tac "" *) (assert_by + (Name acc_rec_arg_id) (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml index 16076479..b03bdf31 100644 --- a/contrib/funind/functional_principles_types.ml +++ b/contrib/funind/functional_principles_types.ml @@ -552,13 +552,31 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent | _ -> anomaly "" in let (_,(const,_,_)) = - build_functional_principle false - first_type - (Array.of_list sorts) - this_block_funs - 0 - (prove_princ_for_struct false 0 (Array.of_list funs)) - (fun _ _ _ -> ()) + try + build_functional_principle false + first_type + (Array.of_list sorts) + this_block_funs + 0 + (prove_princ_for_struct false 0 (Array.of_list funs)) + (fun _ _ _ -> ()) + with e -> + begin + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in + let n = String.length "___________princ_________" in + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" + then Pfedit.delete_current_proof () + else () + else () + with _ -> () + end; + raise (Defining_principle e) + end + in incr i; let opacity = diff --git a/contrib/funind/g_indfun.ml4 b/contrib/funind/g_indfun.ml4 index d435f513..a79b46d9 100644 --- a/contrib/funind/g_indfun.ml4 +++ b/contrib/funind/g_indfun.ml4 @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) +open Util open Term open Names open Pp @@ -128,25 +129,52 @@ ARGUMENT EXTEND auto_using' | [ ] -> [ [] ] END +let pr_rec_annotation2_aux s r id l = + str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ + Util.pr_opt Nameops.pr_id id ++ + Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}" + +let pr_rec_annotation2 = function + | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}" + | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l + | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l + VERNAC ARGUMENT EXTEND rec_annotation2 +PRINTED BY pr_rec_annotation2 [ "{" "struct" ident(id) "}"] -> [ Struct id ] | [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] | [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] END +let pr_binder2 (idl,c) = + str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ + str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")" VERNAC ARGUMENT EXTEND binder2 - [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> - [ - LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) ] +PRINTED BY pr_binder2 + [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ (idl,c) ] END +let make_binder2 (idl,c) = + LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) + +let pr_rec_definition2 (id,bl,annot,type_,def) = + Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ + Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++ + Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ + Ppconstr.pr_lconstr_expr def VERNAC ARGUMENT EXTEND rec_definition2 - [ ident(id) binder2_list( bl) - rec_annotation2_opt(annot) ":" lconstr( type_) +PRINTED BY pr_rec_definition2 + [ ident(id) binder2_list(bl) + rec_annotation2_opt(annot) ":" lconstr(type_) ":=" lconstr(def)] -> - [let names = List.map snd (Topconstr.names_of_local_assums bl) in + [ (id,bl,annot,type_,def) ] +END + +let make_rec_definitions2 (id,bl,annot,type_,def) = + let bl = List.map make_binder2 bl in + let names = List.map snd (Topconstr.names_of_local_assums bl) in let check_one_name () = if List.length names > 1 then Util.user_err_loc @@ -173,52 +201,73 @@ VERNAC ARGUMENT EXTEND rec_definition2 | Some an -> check_exists_args an in - ((Util.dummy_loc,id), ni, bl, type_, def) ] - END - - -VERNAC ARGUMENT EXTEND rec_definitions2 -| [ rec_definition2(rd) ] -> [ [rd] ] -| [ rec_definition2(hd) "with" rec_definitions2(tl) ] -> [ hd::tl ] -END + ((Util.dummy_loc,id), ni, bl, type_, def) VERNAC COMMAND EXTEND Function - ["Function" rec_definitions2(recsl)] -> + ["Function" ne_rec_definition2_list_sep(recsl,"with")] -> [ - do_generate_principle false recsl; + do_generate_principle false (List.map make_rec_definitions2 recsl); ] END +let pr_fun_scheme_arg (princ_name,fun_name,s) = + Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ + Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ + Ppconstr.pr_rawsort s VERNAC ARGUMENT EXTEND fun_scheme_arg +PRINTED BY pr_fun_scheme_arg | [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] END -VERNAC ARGUMENT EXTEND fun_scheme_args -| [ fun_scheme_arg(fa) ] -> [ [fa] ] -| [ fun_scheme_arg(fa) "with" fun_scheme_args(fas) ] -> [fa::fas] -END + +let warning_error names e = + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) + | Defining_principle e -> + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + | _ -> anomaly "" + VERNAC COMMAND EXTEND NewFunctionalScheme - ["Functional" "Scheme" fun_scheme_args(fas) ] -> + ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> [ - try - Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - match fas with - | (_,fun_name,_)::_ -> - begin - begin - make_graph (Nametab.global fun_name) - end - ; - try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - Util.error ("Cannot generate induction principle(s)") - end - | _ -> assert false (* we can only have non empty list *) + begin + try + Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + begin + match fas with + | (_,fun_name,_)::_ -> + begin + begin + make_graph (Nametab.global fun_name) + end + ; + try Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + Util.error ("Cannot generate induction principle(s)") + | e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e + + end + | _ -> assert false (* we can only have non empty list *) + end + | e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e + + end ] END (***** debug only ***) @@ -307,9 +356,9 @@ let mkEq typ c1 c2 = let poseq_unsafe idunsafe cstr gl = let typ = Tacmach.pf_type_of gl cstr in tclTHEN - (Tactics.letin_tac None (Name idunsafe) cstr allClauses) + (Tactics.letin_tac None (Name idunsafe) cstr None allClauses) (tclTHENFIRST - (Tactics.assert_as true (Util.dummy_loc,IntroAnonymous) (mkEq typ (mkVar idunsafe) cstr)) + (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) Tactics.reflexivity) gl diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index 79ef0097..b6b2cbd1 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -168,7 +168,7 @@ let build_newrecursive if Impargs.is_implicit_args() then Impargs.compute_implicits env0 arity else [] in - let impls' =(recname,([],impl,Notation.compute_arguments_scope arity))::impls in + let impls' =(recname,(Constrintern.Recursive,[],impl,Notation.compute_arguments_scope arity))::impls in (Environ.push_named (recname,None,arity) env, impls')) (env0,[]) lnameargsardef in let recdef = @@ -612,7 +612,9 @@ let rec add_args id new_args b = CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) | CCast(loc,b1,CastCoerce) -> CCast(loc,add_args id new_args b1,CastCoerce) + | CRecord _ -> anomaly "add_args : CRecord" | CNotation _ -> anomaly "add_args : CNotation" + | CGeneralization _ -> anomaly "add_args : CGeneralization" | CPrim _ -> b | CDelimiters _ -> anomaly "add_args : CDelimiters" | CDynamic _ -> anomaly "add_args : CDynamic" diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml index 4010b49d..a3c169b7 100644 --- a/contrib/funind/indfun_common.ml +++ b/contrib/funind/indfun_common.ml @@ -238,20 +238,19 @@ let with_full_print f a = and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in - let old_dump = !Flags.dump in Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; Impargs.make_contextual_implicit_args false; - Flags.dump := false; + Dumpglob.pause (); try let res = f a in Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; - Flags.dump := old_dump; + Dumpglob.continue (); res with | e -> @@ -259,7 +258,7 @@ let with_full_print f a = Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; - Flags.dump := old_dump; + Dumpglob.continue (); raise e diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index f62d70ab..5c8f0871 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -445,10 +445,10 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem in tclTHENSEQ [ observe_tac "intro args_names" (tclMAP h_intro args_names); - observe_tac "principle" (forward - (Some (h_exact f_principle)) - (dummy_loc,Genarg.IntroIdentifier principle_id) - princ_type); + observe_tac "principle" (assert_by + (Name principle_id) + princ_type + (h_exact f_principle)); tclTHEN_i (observe_tac "functional_induction" ( fun g -> diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml index ec456aae..9bbd165d 100644 --- a/contrib/funind/merge.ml +++ b/contrib/funind/merge.ml @@ -855,7 +855,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = [rawlist], named ident. FIXME: params et cstr_expr (arity) *) let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(identifier * rawconstr) list):inductive_expr = + (rawlist:(identifier * rawconstr) list) = let lident = dummy_loc, shift.ident in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in @@ -863,7 +863,7 @@ let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift List.map (* zeta_normalize t ? *) (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) rawlist in - lident , bindlist , cstr_expr , lcstor_expr + lident , bindlist , Some cstr_expr , lcstor_expr diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml index 08a97fd2..09b7fbdf 100644 --- a/contrib/funind/rawterm_to_relation.ml +++ b/contrib/funind/rawterm_to_relation.ml @@ -1192,7 +1192,7 @@ let do_build_inductive let rel_ind i ext_rel_constructors = ((dummy_loc,relnames.(i)), rel_params, - rel_arities.(i), + Some rel_arities.(i), ext_rel_constructors),None in let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in @@ -1224,9 +1224,14 @@ let do_build_inductive | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) + ++ fnl () ++ msg in observe (msg); @@ -1234,9 +1239,14 @@ let do_build_inductive | e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) + ++ fnl () ++ Cerrors.explain_exn e in observe msg; diff --git a/contrib/funind/recdef.ml b/contrib/funind/recdef.ml index 5bd7a6b2..6dc0d5bf 100644 --- a/contrib/funind/recdef.ml +++ b/contrib/funind/recdef.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: recdef.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: recdef.ml 11671 2008-12-12 12:43:03Z herbelin $ *) open Term open Termops @@ -740,7 +740,6 @@ let termination_proof_header is_mes input_type ids args_id relation (observe_tac "first assert" (assert_tac - true (* the assert thm is in first subgoal *) (Name wf_rec_arg) (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) @@ -753,7 +752,6 @@ let termination_proof_header is_mes input_type ids args_id relation (observe_tac "second assert" (assert_tac - true (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) ) @@ -1157,12 +1155,12 @@ let rec introduce_all_values_eq cont_tac functional termine [] -> let heq2 = next_global_ident_away true heq_id ids in tclTHENLIST - [forward None (dummy_loc,IntroIdentifier heq2) + [pose_proof (Name heq2) (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); simpl_iter (onHyp heq2); unfold_in_hyp [((true,[1]), evaluable_of_global_reference (global_of_constr functional))] - ((all_occurrences_expr, heq2), Tacexpr.InHyp); + ((all_occurrences_expr, heq2), InHyp); tclTHENS (fun gls -> let t_eq = compute_renamed_type gls (mkVar heq2) in diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index 32338523..2eb2c381 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -76,7 +76,7 @@ and ct_COMMAND = | CT_go of ct_INT_OR_LOCN | CT_guarded | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_hint_extern of ct_INT * ct_FORMULA_OPT * ct_TACTIC_COM * ct_ID_LIST | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index 767a7dd6..483453cb 100644 --- a/contrib/interface/blast.ml +++ b/contrib/interface/blast.ml @@ -148,6 +148,8 @@ let pp_string x = (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) (***************************************************************************) +let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) + let unify_e_resolve (c,clenv) gls = let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in @@ -190,12 +192,11 @@ and e_my_find_search db_list local_db hdc concl = tclTHEN (unify_e_resolve (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> Auto.conclPattern concl - (Option.get p) tacast + | Extern tacast -> Auto.conclPattern concl p tacast in - (free_try tac,fmt_autotactic t)) + (free_try tac,pr_autotactic t)) (*i - fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls with e when Logic.catchable_exception(e) -> (Format.print_string "Fail\n"; @@ -207,14 +208,14 @@ and e_my_find_search db_list local_db hdc concl = and e_trivial_resolve db_list local_db gl = try - Auto.priority + priority (e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = try List.map snd (e_my_find_search db_list local_db - (List.hd (head_constr_bound gl [])) gl) + (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) @@ -406,13 +407,12 @@ and my_find_search db_list local_db hdc concl = (unify_resolve st (term,cl)) (trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> - conclPattern concl (Option.get p) tacast)) + | Extern tacast -> conclPattern concl p tacast)) tacl and trivial_resolve db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in + let hdconstr = fst (head_constr_bound cl) in priority (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) with Bound | Not_found -> @@ -424,7 +424,7 @@ and trivial_resolve db_list local_db cl = let possible_resolve db_list local_db cl = try - let hdconstr = List.hd (head_constr_bound cl []) in + let hdconstr = fst (head_constr_bound cl) in List.map snd (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) with Bound | Not_found -> @@ -432,8 +432,8 @@ let possible_resolve db_list local_db cl = let decomp_unary_term c gls = let typc = pf_type_of gls c in - let hd = List.hd (head_constr typc) in - if Hipattern.is_conjunction hd then + let t = head_constr typc in + if Hipattern.is_conjunction (applist t) then simplest_case c gls else errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") @@ -473,7 +473,7 @@ let rec search_gen decomp n db_list local_db extra_sign goal = let hintl = try [make_apply_entry (pf_env g') (project g') - (true,false) + (true,true,false) None (mkVar hid,htyp)] with Failure _ -> [] diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 index a4dc0eac..51dce4f7 100644 --- a/contrib/interface/centaur.ml4 +++ b/contrib/interface/centaur.ml4 @@ -545,8 +545,12 @@ let solve_hook n = let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s) let interp_search_about_item = function - | SearchRef qid -> GlobSearchRef (Nametab.global qid) - | SearchString s -> GlobSearchString s + | SearchSubPattern pat -> + let _,pat = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in + GlobSearchSubPattern pat + | SearchString (s,_) -> + warning "Notation case not taken into account"; + GlobSearchString s let pcoq_search s l = (* LEM: I don't understand why this is done in this way (redoing the @@ -559,12 +563,12 @@ let pcoq_search s l = begin match s with | SearchAbout sl -> raw_search_about (filter_by_module_from_list l) add_search - (List.map interp_search_about_item sl) + (List.map (on_snd interp_search_about_item) sl) | SearchPattern c -> - let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in raw_pattern_search (filter_by_module_from_list l) add_search pat | SearchRewrite c -> - let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in raw_search_rewrite (filter_by_module_from_list l) add_search pat; | SearchHead locqid -> filtered_search @@ -579,7 +583,7 @@ let rec hyp_pattern_filter pat name a c = | Prod(_, hyp, c2) -> (try (* let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in - let _ = msgnl ((str "PAT ") ++ (Printer.pr_pattern pat)) in *) + let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *) if Matching.is_matching pat hyp then (msgnl (str "ok"); true) else @@ -589,7 +593,7 @@ let rec hyp_pattern_filter pat name a c = | _ -> false;; let hyp_search_pattern c l = - let _, pat = interp_constrpattern Evd.empty (Global.env()) c in + let _, pat = intern_constr_pattern Evd.empty (Global.env()) c in ctv_SEARCH_LIST := []; gen_filtered_search (fun s a c -> (filter_by_module_from_list l s a c && @@ -638,8 +642,8 @@ let pcoq_term_pr = { * Except with right bool/env which I'll get :) *) pr_lconstr_expr = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr c) ++ str ")"); - pr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_pattern_expr c)); - pr_lpattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lpattern_expr c)) + pr_constr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_constr_pattern_expr c)); + pr_lconstr_pattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lconstr_pattern_expr c)) } let start_pcoq_trees () = diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml index 8096bc31..c2ab2dc8 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -99,7 +99,7 @@ let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = with Failure s -> failwith "internal" in let _, constr_pat = - interp_constrpattern Evd.empty (Global.env()) + intern_constr_pattern Evd.empty (Global.env()) ((*ct_to_ast*) pat) in let subst = matches constr_pat term_to_match in if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml index 203bc9e3..e59de34a 100644 --- a/contrib/interface/depends.ml +++ b/contrib/interface/depends.ml @@ -67,6 +67,7 @@ let explore_tree pfs = | Move (bool, identifier, identifier') -> "Move" | Rename (identifier, identifier') -> "Rename" | Change_evars -> "Change_evars" + | Order _ -> "Order" in let pt = proof_of_pftreestate pfs in (* We expect 0 *) @@ -280,8 +281,8 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacExact c | TacExactNoCheck c | TacVmCastNoCheck c -> depends_of_'constr c acc - | TacApply (_, _, [cb]) -> depends_of_'constr_with_bindings cb acc - | TacApply (_, _, _) -> failwith "TODO" + | TacApply (_, _, [cb], None) -> depends_of_'constr_with_bindings cb acc + | TacApply (_, _, _, _) -> failwith "TODO" | TacElim (_, cwb, cwbo) -> depends_of_'constr_with_bindings cwb (Option.fold_right depends_of_'constr_with_bindings cwbo acc) @@ -420,6 +421,7 @@ and depends_of_prim_rule pr acc = match pr with | Move _ -> acc | Rename _ -> acc | Change_evars -> acc + | Order _ -> acc let rec depends_of_pftree pt acc = match pt.ref with diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index 6b17e739..0dc8f024 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -107,10 +107,10 @@ let convert_one_inductive sp tyi = let env = Global.env () in let envpar = push_rel_context params env in let sp = sp_of_global (IndRef (sp, tyi)) in - (((dummy_loc,basename sp), + (((false,(dummy_loc,basename sp)), convert_env(List.rev params), - (extern_constr true envpar arity), - convert_constructors envpar cstrnames cstrtypes), None);; + Some (extern_constr true envpar arity), Vernacexpr.Inductive_kw , + Constructors (convert_constructors envpar cstrnames cstrtypes)), None);; (* This function converts a Mutual inductive definition to a Coqast.t. It is obtained directly from print_mutual in pretty.ml. However, all @@ -121,7 +121,7 @@ let mutual_to_ast_list sp mib = let _, l = Array.fold_right (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in - VernacInductive (mib.mind_finite, l) + VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), l) :: (implicit_args_to_ast_list sp mipv);; let constr_to_ast v = diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index bf8614b4..1bbab5fe 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -330,7 +330,7 @@ let add_path_action reqid string_arg = let print_version_action () = msgnl (mt ()); - msgnl (str "$Id: parse.ml 9476 2007-01-10 15:44:44Z lmamane $");; + msgnl (str "$Id: parse.ml 11749 2009-01-05 14:01:04Z notin $");; let load_syntax_action reqid module_name = msg (str "loading " ++ str module_name ++ str "... "); @@ -370,7 +370,7 @@ Libobject.relax true; (let coqdir = try Sys.getenv "COQDIR" with Not_found -> - let coqdir = Coq_config.coqlib in + let coqdir = Envars.coqlib () in if Sys.file_exists coqdir then coqdir else diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml index b1244d15..a157ca92 100644 --- a/contrib/interface/paths.ml +++ b/contrib/interface/paths.ml @@ -23,4 +23,4 @@ let rec lex_smaller p1 p2 = match p1,p2 with [], _ -> true | a::tl1, b::tl2 when a < b -> true | a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2 -| _ -> false;; \ No newline at end of file +| _ -> false;; diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml index 65eadf13..01747aa5 100644 --- a/contrib/interface/pbp.ml +++ b/contrib/interface/pbp.ml @@ -171,7 +171,7 @@ let make_pbp_atomic_tactic = function | PbpRight -> TacAtom (zz, TacRight (false,NoBindings)) | PbpIntros l -> TacAtom (zz, TacIntroPattern l) | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) - | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings])) + | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings],None)) | PbpElim (hyp_name, names) -> let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in TacAtom diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index 4b9c1332..cf861642 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -1202,7 +1202,8 @@ let rec natural_ntree ig ntree = | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in natural_induction ig lh g gs ge id ltree true - | TacApply (_,false,[c,_]) -> natural_apply ig lh g gs (snd c) ltree + | TacApply (_,false,[c,_],None) -> + natural_apply ig lh g gs (snd c) ltree | TacExact c -> natural_exact ig lh g gs (snd c) ltree | TacCut c -> natural_cut ig lh g gs (snd c) ltree | TacExtend (_,"CutIntro",[a]) -> diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index 551ad3a3..94609009 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -246,7 +246,7 @@ and fCOMMAND = function fNODE "hint_destruct" 6 | CT_hint_extern(x1, x2, x3, x4) -> fINT x1 ++ - fFORMULA x2 ++ + fFORMULA_OPT x2 ++ fTACTIC_COM x3 ++ fID_LIST x4 ++ fNODE "hint_extern" 4 diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index da4908e5..e3cd56a0 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -7,6 +7,7 @@ open Names;; open Ascent;; open Genarg;; open Rawterm;; +open Termops;; open Tacexpr;; open Vernacexpr;; open Decl_kinds;; @@ -274,9 +275,11 @@ let rec xlate_match_pattern = CT_coerce_NUM_to_MATCH_PATTERN (CT_int_encapsulator(Bigint.to_string n)) | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO" - | CPatNotation(_, s, l) -> + | CPatNotation(_, s, (l,[])) -> CT_pattern_notation(CT_string s, CT_match_pattern_list(List.map xlate_match_pattern l)) + | CPatNotation(_, s, (l,_)) -> + xlate_error "CPatNotation (recursive notation): TODO" ;; @@ -373,6 +376,7 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function (xlate_formula f, List.map xlate_formula_expl l')) | CApp(_, (_,f), l) -> CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) + | CRecord (_,_,_) -> xlate_error "CRecord: TODO" | CCases (_, _, _, [], _) -> assert false | CCases (_, _, ret_type, tm::tml, eqns)-> CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm, @@ -392,7 +396,9 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function xlate_formula b1, xlate_formula b2) | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s) - | CNotation(_, s, l) -> notation_to_formula s (List.map xlate_formula l) + | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l) + | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO" + | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO" | CPrim (_, Numeral i) -> CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i)) | CPrim (_, String _) -> xlate_error "CPrim (String): TODO" @@ -642,12 +648,14 @@ let is_tactic_special_case = function let xlate_context_pattern = function | Term v -> CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) - | Subterm (idopt, v) -> + | Subterm (b, idopt, v) -> (* TODO: application pattern *) CT_context(xlate_ident_opt idopt, xlate_formula v) let xlate_match_context_hyps = function - | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b);; + | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b) + | Def (na,b,t) -> xlate_error "TODO: Let hyps" + (* CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b, xlate_context_pattern t);; *) let xlate_arg_to_id_opt = function Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id)) @@ -1155,12 +1163,12 @@ and xlate_tac = xlate_error "TODO: trivial using" | TacReduce (red, l) -> CT_reduce (xlate_red_tactic red, xlate_clause l) - | TacApply (true,false,[c,bindl]) -> + | TacApply (true,false,[c,bindl],None) -> CT_apply (xlate_formula c, xlate_bindings bindl) - | TacApply (true,true,[c,bindl]) -> + | TacApply (true,true,[c,bindl],None) -> CT_eapply (xlate_formula c, xlate_bindings bindl) - | TacApply (_,_,_) -> - xlate_error "TODO: simple (e)apply and iterated apply" + | TacApply (_,_,_,_) -> + xlate_error "TODO: simple (e)apply and iterated apply and apply in" | TacConstructor (false,n_or_meta, bindl) -> let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" in CT_constructor (CT_int n, xlate_bindings bindl) @@ -1248,13 +1256,13 @@ and xlate_tac = but the structures are different *) xlate_clause cl) | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember" - | TacAssert (None, (_,IntroIdentifier id), c) -> + | TacAssert (None, Some (_,IntroIdentifier id), c) -> CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (None, (_,IntroAnonymous), c) -> + | TacAssert (None, None, c) -> CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert (Some (TacId []), (_,IntroIdentifier id), c) -> + | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (Some (TacId []), (_,IntroAnonymous), c) -> + | TacAssert (Some (TacId []), None, c) -> CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c) | TacAssert _ -> xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'" @@ -1302,11 +1310,13 @@ and coerce_genarg_to_TARG x = (CT_coerce_ID_to_ID_OR_INT id)) | IntroPatternArgType -> xlate_error "TODO" - | IdentArgType -> + | IdentArgType true -> let id = xlate_ident (out_gen rawwit_ident x) in CT_coerce_FORMULA_OR_INT_to_TARG (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_ID_to_ID_OR_INT id)) + | IdentArgType false -> + xlate_error "TODO" | VarArgType -> let id = xlate_ident (snd (out_gen rawwit_var x)) in CT_coerce_FORMULA_OR_INT_to_TARG @@ -1400,11 +1410,13 @@ let coerce_genarg_to_VARG x = (CT_coerce_ID_to_ID_OPT id)) | IntroPatternArgType -> xlate_error "TODO" - | IdentArgType -> + | IdentArgType true -> let id = xlate_ident (out_gen rawwit_ident x) in CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT id)) + | IdentArgType false -> + xlate_error "TODO" | VarArgType -> let id = xlate_ident (snd (out_gen rawwit_var x)) in CT_coerce_ID_OPT_OR_ALL_to_VARG @@ -1489,7 +1501,7 @@ let build_constructors l = CT_constr_list (List.map f l) let build_record_field_list l = - let build_record_field (coe,d) = match d with + let build_record_field ((coe,d),not) = match d with | AssumExpr (id,c) -> if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c) else @@ -1735,6 +1747,8 @@ let rec xlate_vernac = (fst::rest) -> CT_formula_ne_list(fst,rest) | _ -> assert false in CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t) + | VernacCreateHintDb (local,dbname,b) -> + xlate_error "TODO: VernacCreateHintDb" | VernacHints (local,dbnames,h) -> let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in (match h with @@ -1749,7 +1763,10 @@ let rec xlate_vernac = CT_hints(CT_ident "Constructors", CT_id_ne_list(n1, names), dblist) | HintsExtern (n, c, t) -> - CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist) + let pat = match c with + | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none) + | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) + in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist) | HintsImmediate l -> let f1, formulas = match List.map xlate_formula l with a :: tl -> a, tl @@ -1768,7 +1785,7 @@ let rec xlate_vernac = | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) | HintsResolve l -> - let f1, formulas = match List.map xlate_formula (List.map snd l) with + let f1, formulas = match List.map xlate_formula (List.map pi3 l) with a :: tl -> a, tl | _ -> failwith "" in let l' = CT_formula_ne_list(f1, formulas) in @@ -1793,6 +1810,16 @@ let rec xlate_vernac = CT_id_ne_list(n1, names), dblist) else CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) + | HintsTransparency (l,b) -> + let n1, names = match List.map loc_qualid_to_ct_ID l with + n1 :: names -> n1, names + | _ -> failwith "" in + let ty = if b then "Transparent" else "Opaque" in + if local then + CT_local_hints(CT_ident ty, + CT_id_ne_list(n1, names), dblist) + else + CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) | HintsDestruct(id, n, loc, f, t) -> let dl = match loc with ConclLocation() -> CT_conclusion_location @@ -1859,7 +1886,8 @@ let rec xlate_vernac = | PrintHint id -> CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id)) | PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE - | PrintLoadPath -> CT_print_loadpath + | PrintLoadPath None -> CT_print_loadpath + | PrintLoadPath _ -> xlate_error "TODO: Print LoadPath dir" | PrintMLLoadPath -> CT_ml_print_path | PrintMLModules -> CT_ml_print_modules | PrintGraph -> CT_print_graph @@ -1878,7 +1906,6 @@ let rec xlate_vernac = xlate_error "TODO: Print TypeClasses" | PrintInspect n -> CT_inspect (CT_int n) | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) - | PrintSetoids -> CT_print_setoids | PrintTables -> CT_print_tables | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a) | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a) @@ -1927,37 +1954,44 @@ let rec xlate_vernac = | SearchRewrite c -> CT_search_rewrite(xlate_formula c, translated_restriction) | SearchAbout (a::l) -> - let xlate_search_about_item it = + let xlate_search_about_item (b,it) = + if not b then xlate_error "TODO: negative searchabout constraint"; match it with - SearchRef x -> + SearchSubPattern (CRef x) -> CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | SearchString s -> - CT_coerce_STRING_to_ID_OR_STRING(CT_string s) in + | SearchString (s,None) -> + CT_coerce_STRING_to_ID_OR_STRING(CT_string s) + | SearchString _ | SearchSubPattern _ -> + xlate_error + "TODO: search subpatterns or notation with explicit scope" + in CT_search_about (CT_id_or_string_ne_list(xlate_search_about_item a, List.map xlate_search_about_item l), translated_restriction) | SearchAbout [] -> assert false) - | (*Record from tactics/Record.v *) - VernacRecord - (_, (add_coercion, (_,s)), binders, c1, - rec_constructor_or_none, field_list) -> - let record_constructor = - xlate_ident_opt (Option.map snd rec_constructor_or_none) in - CT_record - ((if add_coercion then CT_coercion_atm else - CT_coerce_NONE_to_COERCION_OPT(CT_none)), - xlate_ident s, xlate_binder_list binders, - xlate_formula c1, record_constructor, - build_record_field_list field_list) +(* | (\*Record from tactics/Record.v *\) *) +(* VernacRecord *) +(* (_, (add_coercion, (_,s)), binders, c1, *) +(* rec_constructor_or_none, field_list) -> *) +(* let record_constructor = *) +(* xlate_ident_opt (Option.map snd rec_constructor_or_none) in *) +(* CT_record *) +(* ((if add_coercion then CT_coercion_atm else *) +(* CT_coerce_NONE_to_COERCION_OPT(CT_none)), *) +(* xlate_ident s, xlate_binder_list binders, *) +(* xlate_formula (Option.get c1), record_constructor, *) +(* build_record_field_list field_list) *) | VernacInductive (isind, lmi) -> - let co_or_ind = if isind then "Inductive" else "CoInductive" in - let strip_mutind (((_,s), parameters, c, constructors), notopt) = + let co_or_ind = if Decl_kinds.recursivity_flag_of_kind isind then "Inductive" else "CoInductive" in + let strip_mutind = function + (((_, (_,s)), parameters, c, _, Constructors constructors), notopt) -> CT_ind_spec - (xlate_ident s, xlate_binder_list parameters, xlate_formula c, + (xlate_ident s, xlate_binder_list parameters, xlate_formula (Option.get c), build_constructors constructors, - translate_opt_notation_decl notopt) in + translate_opt_notation_decl notopt) + | _ -> xlate_error "TODO: Record notation in (Co)Inductive" in CT_mind_decl (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) | VernacFixpoint ([],_) -> xlate_error "mutual recursive" @@ -2116,7 +2150,7 @@ let rec xlate_vernac = (* Type Classes *) | VernacDeclareInstance _|VernacContext _| - VernacInstance (_, _, _, _, _)|VernacClass (_, _, _, _, _) -> + VernacInstance (_, _, _, _, _) -> xlate_error "TODO: Type Classes commands" | VernacResetName id -> CT_reset (xlate_ident (snd id)) diff --git a/contrib/jprover/README b/contrib/jprover/README deleted file mode 100644 index ec654a03..00000000 --- a/contrib/jprover/README +++ /dev/null @@ -1,76 +0,0 @@ -An intuitionistic first-order theorem prover -- JProver. - -Usage: - -Require JProver. -Jp [num]. - -Whem [num] is provided, proof is done automatically with -the multiplicity limit [num], otherwise no limit is forced -and JProver may not terminate. - -Example: - -Require JProver. -Coq < Goal (P:Prop) P->P. -1 subgoal - -============================ - (P:Prop)P->P - -Unnamed_thm < Jp 1. -Proof is built. -Subtree proved! ------------------------------------------ - -Description: -JProver is a theorem prover for first-order intuitionistic logic. -It is originally implemented by Stephan Schmitt and then integrated into -MetaPRL by Aleksey Nogin (see jall.ml). After this, Huang extracted the -necessary ML-codes from MetaPRL and then integrated it into Coq. -The MetaPRL URL is http://metaprl.org/. For more information on -integrating JProver into interactive proof assistants, please refer to - - "Stephan Schmitt, Lori Lorigo, Christoph Kreitz, and Aleksey Nogin, - Jprover: Integrating connection-based theorem proving into interactive - proof assistants. In International Joint Conference on Automated - Reasoning, volume 2083 of Lecture Notes in Artificial Intelligence, - pages 421-426. Springer-Verlag, 2001" - - http://www.cs.cornell.edu/nogin/papers/jprover.html - - -Structure of this directory: -This directory contains - - README ------ this file - jall.ml ------ the main module of JProver - jtunify.ml ------ string unification procedures for jall.ml - jlogic.ml ------ interface module of jall.ml - jterm.ml - opname.ml ------ implement the infrastructure for jall.ml - jprover.ml4 ------ the interface of jall.ml to Coq - JProver.v ------ declaration for Coq - Makefile ------ the makefile - go ------ batch file to load JProver to Coq dynamically - - -Comments: -1. The original is located in meta-prl/refiner/reflib of the -MetaPRL directory. Some parts of this file are modified by Huang. - -2. is also located in meta-prl/refiner/reflib with no modification. - -3. is modified from meta-prl/refiner/reflib/jlogic_sig.mlz. - -4. and are modified from the standard term module -of MetaPRL in meta-prl/refiner/term_std. - -5. The Jp tactic currently cannot prove formula such as - ((x:nat) (P x)) -> (EX y:nat| (P y)), which requires extra constants -in the domain when the left-All rule is applied. - - - -by Huang Guan-Shieng (Guan-Shieng.Huang@lri.fr), March 2002. - - diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml deleted file mode 100644 index a9ebe5b6..00000000 --- a/contrib/jprover/jall.ml +++ /dev/null @@ -1,4599 +0,0 @@ -(* - * JProver first-order automated prover. See the interface file - * for more information and a list of references for JProver. - * - * ---------------------------------------------------------------- - * - * This file is part of MetaPRL, a modular, higher order - * logical framework that provides a logical programming - * environment for OCaml and other languages. - * - * See the file doc/index.html for information on Nuprl, - * OCaml, and more information about this system. - * - * Copyright (C) 2000 Stephan Schmitt - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - * - * Author: Stephan Schmitt - * Modified by: Aleksey Nogin - *) - -open Jterm -open Opname -open Jlogic -open Jtunify - -let ruletable = Jlogic.ruletable - -let free_var_op = make_opname ["free_variable"; "Jprover"] -let jprover_op = make_opname ["jprover"; "string"] - -module JProver (JLogic : JLogicSig) = -struct - type polarity = I | O - - type connective = And | Or | Neg | Imp | All | Ex | At | Null - - type ptype = Alpha | Beta | Gamma | Delta | Phi | Psi | PNull - - type stype = - Alpha_1 | Alpha_2 | Beta_1 | Beta_2 | Gamma_0 | Delta_0 - | Phi_0 | Psi_0 | PNull_0 - - type pos = {name : string; - address : int list; - op : connective; - pol : polarity; - pt : ptype; - st : stype; - label : term} - - type 'pos ftree = - Empty - | NodeAt of 'pos - | NodeA of 'pos * ('pos ftree) array - - type atom = {aname : string; - aaddress : int list; - aprefix : string list; - apredicate : operator; - apol : polarity; - ast : stype; - alabel : term} - - type atom_relations = atom * atom list * atom list -(* all atoms except atom occur in [alpha_set] and [beta_set] of atom*) - -(* beta proofs *) - - type bproof = BEmpty - | RNode of string list * bproof - | CNode of (string * string) - | BNode of string * (string list * bproof) * (string list * bproof) - | AtNode of string * (string * string) - -(* Assume only constants for instantiations, not adapted to terms yet *) - type inf = rule * term * term - -(* proof tree for pretty print and permutation *) - type 'inf ptree = - PEmpty - | PNodeAx of 'inf - | PNodeA of 'inf * 'inf ptree - | PNodeB of 'inf * 'inf ptree * 'inf ptree - - module OrderedAtom = - struct - type t = atom - let compare a1 a2 = if (a1.aname) = (a2.aname) then 0 else - if (a1.aname) < (a2.aname) then -1 else 1 - end - - module AtomSet = Set.Make(OrderedAtom) - - module OrderedString = - struct - type t = string - let compare a1 a2 = if a1 = a2 then 0 else - if a1 < a2 then -1 else 1 - end - - module StringSet = Set.Make(OrderedString) - -(*i let _ = - show_loading "Loading Jall%t" i*) - - let debug_jprover = - create_debug (**) - { debug_name = "jprover"; - debug_description = "Display Jprover operations"; - debug_value = false - } - - let jprover_bug = Invalid_argument "Jprover bug (Jall module)" - -(*****************************************************************) - -(************* printing function *************************************) - -(************ printing T-string unifiers ****************************) - -(* ******* printing ********** *) - - let rec list_to_string s = - match s with - [] -> "" - | f::r -> - f^"."^(list_to_string r) - - let rec print_eqlist eqlist = - match eqlist with - [] -> - print_endline "" - | (atnames,f)::r -> - let (s,t) = f in - let ls = list_to_string s - and lt = list_to_string t in - begin - print_endline ("Atom names: "^(list_to_string atnames)); - print_endline (ls^" = "^lt); - print_eqlist r - end - - let print_equations eqlist = - begin - Format.open_box 0; - Format.force_newline (); - print_endline "Equations:"; - print_eqlist eqlist; - Format.force_newline (); - end - - let rec print_subst sigma = - match sigma with - [] -> - print_endline "" - | f::r -> - let (v,s) = f in - let ls = list_to_string s in - begin - print_endline (v^" = "^ls); - print_subst r - end - - let print_tunify sigma = - let (n,subst) = sigma in - begin - print_endline " "; - print_endline ("MaxVar = "^(string_of_int (n-1))); - print_endline " "; - print_endline "Substitution:"; - print_subst subst; - print_endline " " - end - -(*****************************************************) - -(********* printing atoms and their relations ***********************) - - let print_stype st = - match st with - Alpha_1 -> Format.print_string "Alpha_1" - | Alpha_2 -> Format.print_string "Alpha_2" - | Beta_1 -> Format.print_string "Beta_1" - | Beta_2 -> Format.print_string "Beta_2" - | Gamma_0 -> Format.print_string "Gamma_0" - | Delta_0 -> Format.print_string "Delta_0" - | Phi_0 -> Format.print_string "Phi_0" - | Psi_0 -> Format.print_string "Psi_0" - | PNull_0 -> Format.print_string "PNull_0" - - let print_pol pol = - if pol = O then - Format.print_string "O" - else - Format.print_string "I" - - let rec print_address int_list = - match int_list with - [] -> - Format.print_string "" - | hd::rest -> - begin - Format.print_int hd; - print_address rest - end - - let rec print_prefix prefix_list = - match prefix_list with - [] -> Format.print_string "" - | f::r -> - begin - Format.print_string f; - print_prefix r - end - - let print_atom at tab = - let ({aname=x; aaddress=y; aprefix=z; apredicate=p; apol=a; ast=b; alabel=label}) = at in - begin - Format.print_string ("{aname="^x^"; address="); - print_address y; - Format.print_string "; "; - Format.force_newline (); - Format.print_break (tab+1) (tab+1); - Format.print_string "prefix="; - print_prefix z; - Format.print_string "; predicate=; "; - Format.print_break (tab+1) (tab+1); - Format.print_break (tab+1) (tab+1); - Format.print_string "pol="; - print_pol a; - Format.print_string "; stype="; - print_stype b; - Format.print_string "; arguments=[]"; - Format.print_string "\n alabel="; - print_term stdout label; - Format.print_string "}" - end - - let rec print_atom_list set tab = - match set with - [] -> Format.print_string "" - | (f::r) -> - begin - Format.force_newline (); - Format.print_break (tab) (tab); - print_atom f tab; - print_atom_list r (tab) - end - - let rec print_atom_info atom_relation = - match atom_relation with - [] -> Format.print_string "" - | (a,b,c)::r -> - begin - Format.print_string "atom:"; - Format.force_newline (); - Format.print_break 3 3; - print_atom a 3; - Format.force_newline (); - Format.print_break 0 0; - Format.print_string "alpha_set:"; - print_atom_list b 3; - Format.force_newline (); - Format.print_break 0 0; - Format.print_string "beta_set:"; - print_atom_list c 3; - Format.force_newline (); - Format.force_newline (); - Format.print_break 0 0; - print_atom_info r - end - -(*************** print formula tree, tree ordering etc. ***********) - - let print_ptype pt = - match pt with - Alpha -> Format.print_string "Alpha" - | Beta -> Format.print_string "Beta" - | Gamma -> Format.print_string "Gamma" - | Delta -> Format.print_string "Delta" - | Phi -> Format.print_string "Phi" - | Psi -> Format.print_string "Psi" - | PNull -> Format.print_string "PNull" - - let print_op op = - match op with - At -> Format.print_string "Atom" - | Neg -> Format.print_string "Neg" - | And -> Format.print_string "And" - | Or -> Format.print_string "Or" - | Imp -> Format.print_string "Imp" - | Ex -> Format.print_string "Ex" - | All -> Format.print_string "All" - | Null -> Format.print_string "Null" - - let print_position position tab = - let ({name=x; address=y; op=z; pol=a; pt=b; st=c; label=t}) = position in - begin - Format.print_string ("{name="^x^"; address="); - print_address y; - Format.print_string "; "; - Format.force_newline (); - Format.print_break (tab+1) 0; -(* Format.print_break 0 3; *) - Format.print_string "op="; - print_op z; - Format.print_string "; pol="; - print_pol a; - Format.print_string "; ptype="; - print_ptype b; - Format.print_string "; stype="; - print_stype c; - Format.print_string ";"; - Format.force_newline (); - Format.print_break (tab+1) 0; - Format.print_string "label="; - Format.print_break 0 0; - Format.force_newline (); - Format.print_break tab 0; - print_term stdout t; - Format.print_string "}" - end - - let rec pp_ftree_list tree_list tab = - let rec pp_ftree ftree new_tab = - let dummy = String.make (new_tab-2) ' ' in - match ftree with - Empty -> Format.print_string "" - | NodeAt(position) -> - begin - Format.force_newline (); - Format.print_break new_tab 0; - print_string (dummy^"AtomNode: "); -(* Format.force_newline (); - Format.print_break 0 3; -*) - print_position position new_tab; - Format.force_newline (); - Format.print_break new_tab 0 - end - | NodeA(position,subtrees) -> - let tree_list = Array.to_list subtrees in - begin - Format.force_newline (); - Format.print_break new_tab 0; - Format.print_break 0 0; - print_string (dummy^"InnerNode: "); - print_position position new_tab; - Format.force_newline (); - Format.print_break 0 0; - pp_ftree_list tree_list (new_tab-3) - end - in - let new_tab = tab+5 in - match tree_list with - [] -> Format.print_string "" - | first::rest -> - begin - pp_ftree first new_tab; - pp_ftree_list rest tab - end - - let print_ftree ftree = - begin - Format.open_box 0; - Format.print_break 3 0; - pp_ftree_list [ftree] 0; - Format.print_flush () - end - - let rec stringlist_to_string stringlist = - match stringlist with - [] -> "." - | f::r -> - let rest_s = stringlist_to_string r in - (f^"."^rest_s) - - let rec print_stringlist slist = - match slist with - [] -> - Format.print_string "" - | f::r -> - begin - Format.print_string (f^"."); - print_stringlist r - end - - let rec pp_bproof_list tree_list tab = - let rec pp_bproof ftree new_tab = - let dummy = String.make (new_tab-2) ' ' in - match ftree with - BEmpty -> Format.print_string "" - | CNode((c1,c2)) -> - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break (new_tab-10) 0; - Format.open_box 0; - Format.force_newline (); - Format.print_string (dummy^"CloseNode: connection = ("^c1^","^c2^")"); - Format.print_flush(); -(* Format.force_newline (); - Format.print_break 0 3; -*) - Format.open_box 0; - Format.print_break new_tab 0; - Format.print_flush() - end - | AtNode(posname,(c1,c2)) -> - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break (new_tab-10) 0; - Format.open_box 0; - Format.force_newline (); - Format.print_string (dummy^"AtNode: pos = "^posname^" conneciton = ("^c1^","^c2^")"); - Format.print_flush(); -(* Format.force_newline (); - Format.print_break 0 3; -*) - Format.open_box 0; - Format.print_break new_tab 0; - Format.print_flush() - end - | RNode(alpha_layer,bproof) -> - let alpha_string = stringlist_to_string alpha_layer in - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break new_tab 0; - Format.print_break 0 0; - Format.force_newline (); - Format.print_flush(); - Format.open_box 0; - print_string (dummy^"RootNode: "^alpha_string); - Format.print_flush(); - Format.open_box 0; - Format.print_break 0 0; - Format.print_flush(); - pp_bproof_list [bproof] (new_tab-3) - end - | BNode(posname,(alph1,bproof1),(alph2,bproof2)) -> - let alpha_string1 = stringlist_to_string alph1 - and alpha_string2 = stringlist_to_string alph2 in - begin - Format.open_box 0; - Format.force_newline (); - Format.print_break new_tab 0; - Format.print_break 0 0; - Format.force_newline (); - Format.print_flush(); - Format.open_box 0; - print_string (dummy^"BetaNode: pos = "^posname^" layer1 = "^alpha_string1^" layer2 = "^alpha_string2); - Format.print_flush(); - Format.open_box 0; - Format.print_break 0 0; - Format.print_flush(); - pp_bproof_list [bproof1;bproof2] (new_tab-3) - end - in - let new_tab = tab+5 in - match tree_list with - [] -> Format.print_string "" - | first::rest -> - begin - pp_bproof first new_tab; - pp_bproof_list rest tab - end - - let rec print_pairlist pairlist = - match pairlist with - [] -> Format.print_string "" - | (a,b)::rest -> - begin - Format.print_break 1 1; - Format.print_string ("("^a^","^b^")"); - print_pairlist rest - end - - let print_beta_proof bproof = - begin - Format.open_box 0; - Format.force_newline (); - Format.force_newline (); - Format.print_break 3 0; - pp_bproof_list [bproof] 0; - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.print_flush () - end - - let rec print_treelist treelist = - match treelist with - [] -> - print_endline "END"; - | f::r -> - begin - print_ftree f; - Format.open_box 0; - print_endline ""; - print_endline ""; - print_endline "NEXT TREE"; - print_endline ""; - print_endline ""; - print_treelist r; - Format.print_flush () - end - - let rec print_set_list set_list = - match set_list with - [] -> "" - | f::r -> - (f.aname)^" "^(print_set_list r) - - let print_set set = - let set_list = AtomSet.elements set in - if set_list = [] then "empty" - else - print_set_list set_list - - let print_string_set set = - let set_list = StringSet.elements set in - print_stringlist set_list - - let rec print_list_sets list_of_sets = - match list_of_sets with - [] -> Format.print_string "" - | (pos,fset)::r -> - begin - Format.print_string (pos^": "); (* first element = node which successors depend on *) - print_stringlist (StringSet.elements fset); - Format.force_newline (); - print_list_sets r - end - - let print_ordering list_of_sets = - begin - Format.open_box 0; - print_list_sets list_of_sets; - Format.print_flush () - end - - let rec print_triplelist triplelist = - match triplelist with - [] -> Format.print_string "" - | ((a,b),i)::rest -> - begin - Format.print_break 1 1; - Format.print_string ("(("^a^","^b^"),"^(string_of_int i)^")"); - print_triplelist rest - end - - let print_pos_n pos_n = - Format.print_int pos_n - - let print_formula_info ftree ordering pos_n = - begin - print_ftree ftree; - Format.open_box 0; - Format.force_newline (); - print_ordering ordering; - Format.force_newline (); - Format.force_newline (); - Format.print_string "number of positions: "; - print_pos_n pos_n; - Format.force_newline (); - print_endline ""; - print_endline ""; - Format.print_flush () - end - -(* print sequent proof tree *) - - let pp_rule (pos,r,formula,term) tab = - let rep = ruletable r in - if List.mem rep ["Alll";"Allr";"Exl";"Exr"] then - begin - Format.open_box 0; -(* Format.force_newline (); *) - Format.print_break tab 0; - Format.print_string (pos^": "^rep^" "); - Format.print_flush (); -(* Format.print_break tab 0; - Format.force_newline (); - Format.print_break tab 0; -*) - - Format.open_box 0; - print_term stdout formula; - Format.print_flush (); - Format.open_box 0; - Format.print_string " "; - Format.print_flush (); - Format.open_box 0; - print_term stdout term; - Format.force_newline (); - Format.force_newline (); - Format.print_flush () - end - else - begin - Format.open_box 0; - Format.print_break tab 0; - Format.print_string (pos^": "^rep^" "); - Format.print_flush (); - Format.open_box 0; -(* Format.print_break tab 0; *) - Format.force_newline (); -(* Format.print_break tab 0; *) - print_term stdout formula; - Format.force_newline () - end - - let last addr = - if addr = "" - then "" - else - String.make 1 (String.get addr (String.length addr-1)) - - let rest addr = - if addr = "" - then "" - else - String.sub addr 0 ((String.length addr) - 1) - - let rec get_r_chain addr = - if addr = "" then - 0 - else - let l = last addr in - if l = "l" then - 0 - else (* l = "r" *) - let rs = rest addr in - 1 + (get_r_chain rs) - - let rec tpp seqtree tab addr = - match seqtree with - | PEmpty -> raise jprover_bug - | PNodeAx(rule) -> - let (pos,r,p,pa) = rule in - begin - pp_rule (pos,r,p,pa) tab; -(* Format.force_newline (); *) -(* let mult = get_r_chain addr in *) -(* Format.print_break 100 (tab - (3 * mult)) *) - end - | PNodeA(rule,left) -> - let (pos,r,p,pa) = rule in - begin - pp_rule (pos,r,p,pa) tab; - tpp left tab addr - end - | PNodeB(rule,left,right) -> - let (pos,r,p,pa) = rule in - let newtab = tab + 3 in - begin - pp_rule (pos,r,p,pa) tab; -(* Format.force_newline (); *) -(* Format.print_break 100 newtab; *) - (tpp left newtab (addr^"l")); - (tpp right newtab (addr^"r")) - end - - let tt seqtree = - begin - Format.open_box 0; - tpp seqtree 0 ""; - Format.force_newline (); - Format.close_box (); - Format.print_newline () - end - -(************ END printing functions *********************************) - -(************ Beta proofs and redundancy deletion **********************) - - let rec remove_dups_connections connection_list = - match connection_list with - [] -> [] - | (c1,c2)::r -> - if (List.mem (c1,c2) r) or (List.mem (c2,c1) r) then - (* only one direction variant of a connection stays *) - remove_dups_connections r - else - (c1,c2)::(remove_dups_connections r) - - let rec remove_dups_list list = - match list with - [] -> [] - | f::r -> - if List.mem f r then - remove_dups_list r - else - f::(remove_dups_list r) - - let beta_pure alpha_layer connections beta_expansions = - let (l1,l2) = List.split connections in - let test_list = l1 @ l2 @ beta_expansions in - begin -(* Format.open_box 0; - print_endline ""; - print_stringlist alpha_layer; - Format.print_flush(); - Format.open_box 0; - print_endline ""; - print_stringlist test_list; - print_endline ""; - Format.print_flush(); -*) - not (List.exists (fun x -> (List.mem x test_list)) alpha_layer) - end - - let rec apply_bproof_purity bproof = - match bproof with - BEmpty -> - raise jprover_bug - | CNode((c1,c2)) -> - bproof,[(c1,c2)],[] - | AtNode(_,(c1,c2)) -> - bproof,[(c1,c2)],[] - | RNode(alpha_layer,subproof) -> - let (opt_subproof,min_connections,beta_expansions) = - apply_bproof_purity subproof in - (RNode(alpha_layer,opt_subproof),min_connections,beta_expansions) - | BNode(pos,(alph1,subp1),(alph2,subp2)) -> - let (opt_subp1,min_conn1,beta_exp1) = apply_bproof_purity subp1 in - if beta_pure alph1 min_conn1 beta_exp1 then - begin -(* print_endline ("Left layer of "^pos); *) - (opt_subp1,min_conn1,beta_exp1) - end - else - let (opt_subp2,min_conn2,beta_exp2) = apply_bproof_purity subp2 in - if beta_pure alph2 min_conn2 beta_exp2 then - begin -(* print_endline ("Right layer of "^pos); *) - (opt_subp2,min_conn2,beta_exp2) - end - else - let min_conn = remove_dups_connections (min_conn1 @ min_conn2) - and beta_exp = remove_dups_list ([pos] @ beta_exp1 @ beta_exp2) in - (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2)),min_conn,beta_exp) - - let bproof_purity bproof = - let (opt_bproof,min_connections,_) = apply_bproof_purity bproof in - opt_bproof,min_connections - -(*********** split permutation *****************) - - let rec apply_permutation bproof rep_name direction act_blayer = - match bproof with - BEmpty | RNode(_,_) -> - raise jprover_bug - | AtNode(cx,(c1,c2)) -> - bproof,act_blayer - | CNode((c1,c2)) -> - bproof,act_blayer - | BNode(pos,(alph1,subp1),(alph2,subp2)) -> - if rep_name = pos then - let (new_blayer,replace_branch) = - if direction = "left" then - (alph1,subp1) - else (* direciton = "right" *) - (alph2,subp2) - in - (match replace_branch with - CNode((c1,c2)) -> - (AtNode(c1,(c1,c2))),new_blayer (* perform atom expansion at c1 *) - | _ -> - replace_branch,new_blayer - ) - else - let pproof1,new_blayer1 = apply_permutation subp1 rep_name direction act_blayer in - let pproof2,new_blayer2 = apply_permutation subp2 rep_name direction new_blayer1 in - (BNode(pos,(alph1,pproof1),(alph2,pproof2))),new_blayer2 - - let split_permutation pname opt_bproof = - match opt_bproof with - RNode(alayer,BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) -> - if pos = pname then -(* if topmost beta expansion agrees with pname, then *) -(* only split the beta proof and give back the two subproofs *) - let (osubp1,min_con1) = bproof_purity opt_subp1 - and (osubp2,min_con2) = bproof_purity opt_subp2 in -(* there will be no purity reductions in the beta subproofs. We use this *) -(* predicate to collect the set of used leaf-connections in each subproof*) - ((RNode((alayer @ alph1),osubp1),min_con1), - (RNode((alayer @ alph2),osubp2),min_con2) - ) -(* we combine the branch after topmost beta expansion at pos into one root alpha layer *) -(* -- the beta expansion node pos will not be needed in this root layer *) - else - let perm_bproof1,balph1 = apply_permutation - (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "left" [] - and perm_bproof2,balph2 = apply_permutation - (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "right" [] in - - begin -(* print_endline " "; - print_beta_proof perm_bproof1; - print_endline" " ; - print_beta_proof perm_bproof2; - print_endline" "; -*) - let (osubp1,min_con1) = bproof_purity perm_bproof1 - and (osubp2,min_con2) = bproof_purity perm_bproof2 in - ((RNode((alayer @ balph1),osubp1),min_con1), - (RNode((alayer @ balph2),osubp2),min_con2) - ) - end -(* we combine the branch after the NEW topmost beta expansion at bpos *) -(* into one root alpha layer -- the beta expansion node bpos will not be *) -(* needed in this root layer *) - | _ -> - raise jprover_bug - -(*********** END split permutation *****************) - - let rec list_del list_el el_list = - match el_list with - [] -> - raise jprover_bug - | f::r -> - if list_el = f then - r - else - f::(list_del list_el r) - - let rec list_diff del_list check_list = - match del_list with - [] -> - [] - | f::r -> - if List.mem f check_list then - list_diff r check_list - else - f::(list_diff r check_list) - -(* let rec compute_alpha_layer ftree_list = - match ftree_list with - [] -> - [],[],[] - | f::r -> - (match f with - Empty -> - raise jprover_bug - | NodeAt(pos) -> - let pn = pos.name - and (rnode,ratom,borderings) = compute_alpha_layer r in - ((pn::rnode),(pn::ratom),borderings) - | NodeA(pos,suctrees) -> - let pn = pos.name in - if pos.pt = Beta then - let (rnode,ratom,borderings) = compute_alpha_layer r in - ((pn::rnode),(ratom),(f::borderings)) - else - let suclist = Array.to_list suctrees in - compute_alpha_layer (suclist @ r) - ) - - let rec compute_connection alpha_layer union_atoms connections = - match connections with - [] -> ("none","none") - | (c,d)::r -> - if (List.mem c union_atoms) & (List.mem d union_atoms) then - let (c1,c2) = - if List.mem c alpha_layer then - (c,d) - else - if List.mem d alpha_layer then - (d,c) (* then, d is supposed to occur in [alpha_layer] *) - else - raise (Invalid_argument "Jprover bug: connection match failure") - in - (c1,c2) - else - compute_connection alpha_layer union_atoms r - - let get_beta_suctrees btree = - match btree with - Empty | NodeAt(_) -> raise jprover_bug - | NodeA(pos,suctrees) -> - let b1tree = suctrees.(0) - and b2tree = suctrees.(1) in - (pos.name,b1tree,b2tree) - - let rec build_beta_proof alpha_layer union_atoms beta_orderings connections = - let (c1,c2) = compute_connection alpha_layer union_atoms connections in -(* [c1] is supposed to occur in the lowmost alpha layer of the branch, *) -(* i.e. [aplha_layer] *) - if (c1,c2) = ("none","none") then - (match beta_orderings with - [] -> raise jprover_bug - | btree::r -> - let (beta_pos,suctree1,suctree2) = get_beta_suctrees btree in - let (alpha_layer1, atoms1, bordering1) = compute_alpha_layer [suctree1] - and (alpha_layer2, atoms2, bordering2) = compute_alpha_layer [suctree2] in - let bproof1,beta1,closure1 = - build_beta_proof alpha_layer1 (atoms1 @ union_atoms) - (bordering1 @ r) connections - in - let bproof2,beta2,closure2 = - build_beta_proof alpha_layer2 (atoms2 @ union_atoms) - (bordering2 @ r) connections in - (BNode(beta_pos,(alpha_layer1,bproof1),(alpha_layer2,bproof2))),(1+beta1+beta2),(closure1+closure2) - ) - else - CNode((c1,c2)),0,1 - - let construct_beta_proof ftree connections = - let (root_node,root_atoms,beta_orderings) = compute_alpha_layer [ftree] - in - let beta_proof,beta_exp,closures = - build_beta_proof root_node root_atoms beta_orderings connections in - (RNode(root_node,beta_proof)),beta_exp,closures -*) - - -(* *********** New Version with direct computation from extension proof **** *) -(* follows a DIRECT step from proof histories via pr-connection orderings to opt. beta-proofs *) - - let rec compute_alpha_layer ftree_list = - match ftree_list with - [] -> - [] - | f::r -> - (match f with - Empty -> - raise jprover_bug - | NodeAt(pos) -> - let rnode = compute_alpha_layer r in - (pos.name::rnode) - | NodeA(pos,suctrees) -> - if pos.pt = Beta then - let rnode = compute_alpha_layer r in - (pos.name::rnode) - else - let suclist = Array.to_list suctrees in - compute_alpha_layer (suclist @ r) - ) - - let rec compute_beta_difference c1_context c2_context act_context = - match c1_context,c2_context with - ([],c2_context) -> - (list_diff c2_context act_context) -(* both connection partners in the same submatrix; [c1] already isolated *) - | ((fc1::rc1),[]) -> - [] (* [c2] is a reduction step, i.e. isolated before [c1] *) - | ((fc1::rc1),(fc2::rc2)) -> - if fc1 = fc2 then (* common initial beta-expansions *) - compute_beta_difference rc1 rc2 act_context - else - (list_diff c2_context act_context) - - let rec non_closed beta_proof_list = - match beta_proof_list with - [] -> - false - | bpf::rbpf -> - (match bpf with - RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | BEmpty -> true - | CNode(_) -> non_closed rbpf - | BNode(pos,(_,bp1),(_,bp2)) -> non_closed ([bp1;bp2] @ rbpf) - ) - - let rec cut_context pos context = - match context with - [] -> - raise (Invalid_argument "Jprover bug: invalid context element") - | (f,num)::r -> - if pos = f then - context - else - cut_context pos r - - let compute_tree_difference beta_proof c1_context = - match beta_proof with - RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | BEmpty -> c1_context - | BNode(pos,_,_) -> -(* print_endline ("actual root: "^pos); *) - cut_context pos c1_context - - let print_context conn bcontext = - begin - Format.open_box 0; - Format.print_string conn; - Format.print_string ": "; - List.iter (fun x -> let (pos,num) = x in Format.print_string (pos^" "^(string_of_int num)^"")) bcontext; - print_endline " "; - Format.print_flush () - end - - let rec build_opt_beta_proof beta_proof ext_proof beta_atoms beta_layer_list act_context = - let rec add_c2_tree (c1,c2) c2_diff_context = - match c2_diff_context with - [] -> - (CNode(c1,c2),0) - | (f,num)::c2_diff_r -> - let next_beta_proof,next_exp = - add_c2_tree (c1,c2) c2_diff_r in - let (layer1,layer2) = List.assoc f beta_layer_list in - let new_bproof = - if num = 1 then - BNode(f,(layer1,next_beta_proof),(layer2,BEmpty)) - else (* num = 2*) - BNode(f,(layer1,BEmpty),(layer2,next_beta_proof)) - in - (new_bproof,(next_exp+1)) - in - let rec add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context new_act_context = - match c1_diff_context with - [] -> - let (n_c1,n_c2) = - if c2_diff_context = [] then (* make sure that leaf-connection is first element *) - (c1,c2) - else - (c2,c1) - in - let c2_bproof,c2_exp = add_c2_tree (n_c1,n_c2) c2_diff_context in - if c2_exp <> 0 then (* at least one open branch was generated to isloate [c2] *) - begin -(* print_endline "start with new beta-proof"; *) - let new_bproof,new_exp,new_closures,new_rest_proof = - build_opt_beta_proof c2_bproof rest_ext_proof beta_atoms beta_layer_list (act_context @ new_act_context) in - (new_bproof,(new_exp+c2_exp),(new_closures+1),new_rest_proof) - end - else - begin -(* print_endline "proceed with old beta-proof"; *) - (c2_bproof,c2_exp,1,rest_ext_proof) - end - | (f,num)::c1_diff_r -> - let (layer1,layer2) = List.assoc f beta_layer_list in - let next_beta_proof,next_exp,next_closures,next_ext_proof = - add_beta_expansions (c1,c2) rest_ext_proof c1_diff_r c2_diff_context new_act_context in - let new_bproof = - if num = 1 then - BNode(f,(layer1,next_beta_proof),(layer2,BEmpty)) - else (* num = 2*) - BNode(f,(layer1,BEmpty),(layer2,next_beta_proof)) - in - (new_bproof,(next_exp+1),next_closures,next_ext_proof) - - in - let rec insert_connection beta_proof (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context = - begin -(* print_context c1 c1_diff_context; - print_endline ""; - print_context c2 c2_diff_context; - print_endline ""; -*) - match beta_proof with - RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") - | BEmpty -> - add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context - | BNode(pos,(layer1,sproof1),(layer2,sproof2)) -> -(* print_endline (c1^" "^c2^" "^pos); *) - (match c1_diff_context with - [] -> - raise (Invalid_argument "Jprover bug: invalid beta-proof") - | (f,num)::rest_context -> (* f = pos must hold!! *) - if num = 1 then - let (next_bproof,next_exp,next_closure,next_ext_proof) = - insert_connection sproof1 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in - (BNode(pos,(layer1,next_bproof),(layer2,sproof2)),next_exp,next_closure,next_ext_proof) - else (* num = 2 *) - let (next_bproof,next_exp,next_closure,next_ext_proof) = - insert_connection sproof2 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in - (BNode(pos,(layer1,sproof1),(layer2,next_bproof)),next_exp,next_closure,next_ext_proof) - ) - end - - in - match ext_proof with - [] -> - beta_proof,0,0,[] - | (c1,c2)::rproof -> -(* print_endline ("actual connection: "^c1^" "^c2); *) - let c1_context = List.assoc c1 beta_atoms - and c2_context = List.assoc c2 beta_atoms in - let c2_diff_context = compute_beta_difference c1_context c2_context act_context - and c1_diff_context = compute_tree_difference beta_proof c1_context in (* wrt. actual beta-proof *) - let (next_beta_proof,next_exp,next_closures,next_ext_proof) = - insert_connection beta_proof (c1,c2) rproof c1_diff_context c2_diff_context c1_diff_context in - if non_closed [next_beta_proof] then (* at least one branch was generated to isolate [c1] *) - let rest_beta_proof,rest_exp,rest_closures,rest_ext_proof = - build_opt_beta_proof next_beta_proof next_ext_proof beta_atoms beta_layer_list act_context in - rest_beta_proof,(next_exp+rest_exp),(next_closures+rest_closures),rest_ext_proof - else - next_beta_proof,next_exp,next_closures,next_ext_proof - - let rec annotate_atoms beta_context atlist treelist = - let rec annotate_tree beta_context tree atlist = - match tree with - Empty -> - (atlist,[],[]) - | NodeAt(pos) -> - if List.mem pos.name atlist then - let new_atlist = list_del pos.name atlist in - (new_atlist,[(pos.name,beta_context)],[]) - else - (atlist,[],[]) - | NodeA(pos,suctrees) -> - if pos.pt = Beta then - let s1,s2 = suctrees.(0),suctrees.(1) in - let alayer1 = compute_alpha_layer [s1] - and alayer2 = compute_alpha_layer [s2] - and new_beta_context1 = beta_context @ [(pos.name,1)] - and new_beta_context2 = beta_context @ [(pos.name,2)] in - let atlist1,annotates1,blayer_list1 = - annotate_atoms new_beta_context1 atlist [s1] in - let atlist2,annotates2,blayer_list2 = - annotate_atoms new_beta_context2 atlist1 [s2] - in - (atlist2,(annotates1 @ annotates2),((pos.name,(alayer1,alayer2))::(blayer_list1 @ blayer_list2))) - else - annotate_atoms beta_context atlist (Array.to_list suctrees) - in - match treelist with - [] -> (atlist,[],[]) - | f::r -> - let (next_atlist,f_annotates,f_beta_layers) = annotate_tree beta_context f atlist in - let (rest_atlist,rest_annotates,rest_beta_layers) = (annotate_atoms beta_context next_atlist r) - in - (rest_atlist, (f_annotates @ rest_annotates),(f_beta_layers @ rest_beta_layers)) - - let construct_opt_beta_proof ftree ext_proof = - let con1,con2 = List.split ext_proof in - let con_atoms = remove_dups_list (con1 @ con2) in - let (empty_atoms,beta_atoms,beta_layer_list) = annotate_atoms [] con_atoms [ftree] in - let root_node = compute_alpha_layer [ftree] in - let (beta_proof,beta_exp,closures,_) = - build_opt_beta_proof BEmpty ext_proof beta_atoms beta_layer_list [] in - (RNode(root_node,beta_proof)),beta_exp,closures - -(************* permutation ljmc -> lj *********************************) - -(* REAL PERMUTATION STAFF *) - - let subf1 n m subrel = List.mem ((n,m),1) subrel - let subf2 n m subrel = List.mem ((n,m),2) subrel - let tsubf n m tsubrel = List.mem (n,m) tsubrel - -(* Transforms all normal form layers in an LJ proof *) - - let rec modify prooftree (subrel,tsubrel) = - match prooftree with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - prooftree,pos - | PNodeA((pos,inf,form,term),left) -> - let t,qpos = modify left (subrel,tsubrel) in - if List.mem inf [Impr;Negr;Allr] then - PNodeA((pos,inf,form,term),t),pos (* layer bound *) - else if qpos = "Orl-True" then - PNodeA((pos,inf,form,term),t),qpos - else if List.mem inf [Andl;Alll;Exl] then - PNodeA((pos,inf,form,term),t),qpos (* simply propagation *) - else if inf = Exr then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),pos - else t,qpos - else if inf = Negl then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),"" (* empty string *) - else t,qpos - else (* x = Orr *) - if (subf1 pos qpos subrel) then - PNodeA((pos,Orr1,form,term),t),pos (* make Orr for LJ *) - else if (subf2 pos qpos subrel) then - PNodeA((pos,Orr2,form,term),t),pos (* make Orr for LJ *) - else t,qpos - | PNodeB((pos,inf,form,term),left,right) -> - let t,qpos = modify left (subrel,tsubrel) in - if inf = Andr then - if (or) (qpos = "Orl-True") (subf1 pos qpos subrel) then - let s,rpos = modify right (subrel,tsubrel) in (* Orl-True -> subf *) - if (or) (rpos = "Orl-True") (subf2 pos rpos subrel) then - PNodeB((pos,inf,form,term),t,s),pos - else s,rpos - else t,qpos (* not subf -> not Orl-True *) - else if inf = Impl then - if (subf1 pos qpos subrel) then - let s,rpos = modify right (subrel,tsubrel) in - PNodeB((pos,inf,form,term),t,s),"" (* empty string *) - else t,qpos - else (* x = Orl *) - let s,rpos = modify right (subrel,tsubrel) in - PNodeB((pos,inf,form,term),t,s),"Orl-True" - -(* transforms the subproof into an LJ proof between - the beta-inference rule (excluded) and - layer boundary in the branch ptree *) - - let rec rec_modify ptree (subrel,tsubrel) = - match ptree with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - ptree,pos - | PNodeA((pos,inf,form,term),left) -> - if List.mem inf [Impr;Negr;Allr] then - ptree,pos (* layer bound, stop transforming! *) - else - let t,qpos = rec_modify left (subrel,tsubrel) in - if List.mem inf [Andl;Alll;Exl] then - PNodeA((pos,inf,form,term),t),qpos (* simply propagation*) - else if inf = Exr then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),pos - else t,qpos - else if inf = Negl then - if (subf1 pos qpos subrel) then - PNodeA((pos,inf,form,term),t),"" (* empty string *) - else t,qpos - else (* x = Orr *) - if (subf1 pos qpos subrel) then - PNodeA((pos,Orr1,form,term),t),pos (* make Orr for LJ *) - else if (subf2 pos qpos subrel) then - PNodeA((pos,Orr2,form,term),t),pos (* make Orr for LJ *) - else t,qpos - | PNodeB((pos,inf,form,term),left,right) -> - let t,qpos = rec_modify left (subrel,tsubrel) in - if inf = Andr then - if (subf1 pos qpos subrel) then - let s,rpos = rec_modify right (subrel,tsubrel) in - if (subf2 pos rpos subrel) then - PNodeB((pos,inf,form,term),t,s),pos - else s,rpos - else t,qpos - else (* x = Impl since x= Orl cannot occur in the partial layer ptree *) - - if (subf1 pos qpos subrel) then - let s,rpos = rec_modify right (subrel,tsubrel) in - PNodeB((pos,inf,form,term),t,s),"" (* empty string *) - else t,qpos - - let weak_modify rule ptree (subrel,tsubrel) = (* recall rule = or_l *) - let (pos,inf,formlua,term) = rule in - if inf = Orl then - ptree,true - else - let ptreem,qpos = rec_modify ptree (subrel,tsubrel) in - if (subf1 pos qpos subrel) then (* weak_modify will always be applied on left branches *) - ptreem,true - else - ptreem,false - -(* Now, the permutation stuff .... *) - -(* Permutation schemes *) - -(* corresponds to local permutation lemma -- Lemma 3 in the paper -- *) -(* with eigenvariablen renaming and branch modification *) - -(* eigenvariablen renaming and branch modification over *) -(* the whole proofs, i.e. over layer boundaries, too *) - - -(* global variable vor eigenvariable renaming during permutations *) - - let eigen_counter = ref 1 - -(* append renamed paramater "r" to non-quantifier subformulae - of renamed quantifier formulae *) - - let make_new_eigenvariable term = - let op = (dest_term term).term_op in - let opa = (dest_op op).op_params in - let oppar = dest_param opa in - match oppar with - | String ofname::_ -> - let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in - eigen_counter := !eigen_counter + 1; - mk_string_term jprover_op new_eigen_var - | _ -> raise jprover_bug - - - let replace_subterm term oldt rept = - let v_term = var_subst term oldt "dummy_var" in - subst1 v_term "dummy_var" rept - - let rec eigen_rename old_parameter new_parameter ptree = - match ptree with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - let new_form = replace_subterm form old_parameter new_parameter in - PNodeAx((pos,inf,new_form,term)) - | PNodeA((pos,inf,form,term), left) -> - let new_form = replace_subterm form old_parameter new_parameter - and new_term = replace_subterm term old_parameter new_parameter in - let ren_left = eigen_rename old_parameter new_parameter left in - PNodeA((pos,inf,new_form,new_term), ren_left) - | PNodeB((pos,inf,form,term),left, right) -> - let new_form = replace_subterm form old_parameter new_parameter in - let ren_left = eigen_rename old_parameter new_parameter left in - let ren_right = eigen_rename old_parameter new_parameter right in - PNodeB((pos,inf,new_form,term), ren_left, ren_right) - - let rec update_ptree rule subtree direction tsubrel = - match subtree with - PEmpty -> - raise jprover_bug - | PNodeAx(r) -> - subtree - | PNodeA((pos,inf,formula,term), left) -> - if (pos,inf,formula,term) = rule then - left - (* don't delete rule if subformula belongs to renamed instance of quantifiers; *) - (* but this can never occur now since (renamed) formula is part of rule *) - else - let (posn,infn,formn,termn) = rule in - if (&) (List.mem infn [Exl;Allr] ) (term = termn) then - (* this can only occur if eigenvariable rule with same term as termn has been permuted; *) - (* the application of the same eigenvariable introduction on the same subformula with *) - (* different instantiated variables might occur! *) - (* termn cannot occur in terms of permuted quantifier rules due to substitution split *) - (* during reconstruciton of the ljmc proof *) - let new_term = make_new_eigenvariable term in -(* print_endline "Eigenvariable renaming!!!"; *) - eigen_rename termn new_term subtree - else - let left_del = - update_ptree rule left direction tsubrel - in - PNodeA((pos,inf,formula,term), left_del) - | PNodeB((pos,inf,formula,term), left, right) -> - if (pos,inf,formula,term) = rule then - if direction = "l" then - left - else - right (* direction = "r" *) - else - let left_del = update_ptree rule left direction tsubrel in - let right_del = update_ptree rule right direction tsubrel in - PNodeB((pos,inf,formula,term),left_del,right_del) - - let permute r1 r2 ptree la tsubrel = -(* print_endline "permute in"; *) - match ptree,la with - PNodeA(r1, PNodeA(r2,left)),la -> -(* print_endline "1-o-1"; *) - PNodeA(r2, PNodeA(r1,left)) - (* one-over-one *) - | PNodeA(r1, PNodeB(r2,left,right)),la -> -(* print_endline "1-o-2"; *) - PNodeB(r2, PNodeA(r1,left), PNodeA(r1,right)) - (* one-over-two *) - | PNodeB(r1, PNodeA(r2,left), right),"l" -> -(* print_endline "2-o-1 left"; *) - let right_u = update_ptree r2 right "l" tsubrel in - PNodeA(r2, PNodeB(r1, left, right_u)) - (* two-over-one left *) - | PNodeB(r1, left, PNodeA(r2,right)),"r" -> -(* print_endline "2-o-1 right"; *) - let left_u = update_ptree r2 left "l" tsubrel in - PNodeA(r2, PNodeB(r1, left_u, right)) - (* two-over-one right *) - | PNodeB(r1, PNodeB(r2,left2,right2), right),"l" -> -(* print_endline "2-o-2 left"; *) - let right_ul = update_ptree r2 right "l" tsubrel in - let right_ur = update_ptree r2 right "r" tsubrel in - PNodeB(r2,PNodeB(r1,left2,right_ul),PNodeB(r1,right2,right_ur)) - (* two-over-two left *) - | PNodeB(r1, left, PNodeB(r2,left2,right2)),"r" -> -(* print_endline "2-o-2 right"; *) - let left_ul = update_ptree r2 left "l" tsubrel in - let left_ur = update_ptree r2 left "r" tsubrel in - PNodeB(r2,PNodeB(r1,left_ul,left2),PNodeB(r1,left_ur, right2)) - (* two-over-two right *) - | _ -> raise jprover_bug - -(* permute layers, isolate addmissible branches *) - -(* computes if an Andr is d-generatives *) - - let layer_bound rule = - let (pos,inf,formula,term) = rule in - if List.mem inf [Impr;Negr;Allr] then - true - else - false - - let rec orl_free ptree = - match ptree with - PEmpty -> - raise jprover_bug - | PNodeAx(rule) -> - true - | PNodeA(rule,left) -> - if layer_bound rule then - true - else - orl_free left - | PNodeB(rule,left,right) -> - let (pos,inf,formula,term) = rule in - if inf = Orl then - false - else - (&) (orl_free left) (orl_free right) - - let rec dgenerative rule dglist ptree tsubrel = - let (pos,inf,formula,term) = rule in - if List.mem inf [Exr;Orr;Negl] then - true - else if inf = Andr then - if dglist = [] then - false - else - let first,rest = (List.hd dglist),(List.tl dglist) in - let (pos1,inf1,formula1,term1) = first in - if tsubf pos1 pos tsubrel then - true - else - dgenerative rule rest ptree tsubrel - else if inf = Impl then - not (orl_free ptree) - else - false - - -(* to compute a topmost addmissible pair r,o with - the address addr of r in the proof tree -*) - - let rec top_addmissible_pair ptree dglist act_r act_o act_addr tsubrel dummyt = - let rec search_pair ptree dglist act_r act_o act_addr tsubrel = - match ptree with - PEmpty -> raise jprover_bug - | PNodeAx(_) -> raise jprover_bug - | PNodeA(rule, left) -> -(* print_endline "alpha"; *) - if (dgenerative rule dglist left tsubrel) then (* r = Exr,Orr,Negl *) - let newdg = (@) [rule] dglist in - search_pair left newdg act_r rule act_addr tsubrel - else (* Impr, Allr, Notr only for test *) - search_pair left dglist act_r act_o act_addr tsubrel - | PNodeB(rule,left,right) -> -(* print_endline "beta"; *) - let (pos,inf,formula,term) = rule in - if List.mem inf [Andr;Impl] then - let bool = dgenerative rule dglist left tsubrel in - let newdg,newrule = - if bool then - ((@) [rule] dglist),rule - else - dglist,act_o - in - if orl_free left then - search_pair right newdg act_r newrule (act_addr^"r") tsubrel - else (* not orl_free *) - let left_r,left_o,left_addr = - search_pair left newdg act_r newrule (act_addr^"l") tsubrel in - if left_o = ("",Orr,dummyt,dummyt) then - top_addmissible_pair right dglist act_r act_o (act_addr^"r") tsubrel dummyt - else left_r,left_o,left_addr - else (* r = Orl *) - if orl_free left then - top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt - else - let left_r,left_o,left_addr - = search_pair left dglist rule act_o (act_addr^"l") tsubrel in - if left_o = ("",Orr,dummyt,dummyt) then - top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt - else - left_r,left_o,left_addr - in -(* print_endline "top_addmissible_pair in"; *) - if orl_free ptree then (* there must be a orl BELOW an layer bound *) - begin -(* print_endline "orl_free"; *) - act_r,act_o,act_addr - end - else - begin -(* print_endline "orl_full"; *) - search_pair ptree dglist act_r act_o act_addr tsubrel - end - - let next_direction addr act_addr = - String.make 1 (String.get addr (String.length act_addr)) - (* get starts with count 0*) - - let change_last addr d = - let split = (String.length addr) - 1 in - let prec,last = - (String.sub addr 0 split),(String.sub addr split 1) in - prec^d^last - - let last addr = - if addr = "" - then "" - else - String.make 1 (String.get addr (String.length addr-1)) - - let rest addr = - if addr = "" - then "" - else - String.sub addr 0 ((String.length addr) - 1) - - let rec permute_layer ptree dglist (subrel,tsubrel) = - let rec permute_branch r addr act_addr ptree dglist (subrel,tsubrel) = -(* print_endline "pbranch in"; *) - let la = last act_addr in (* no ensure uniqueness at 2-over-x *) - match ptree,la with - PNodeA(o,PNodeA(rule,left)),la -> (* one-over-one *) -(* print_endline " one-over-one "; *) - let permute_result = permute o rule ptree la tsubrel in - begin match permute_result with - PNodeA(r2,left2) -> - let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in - PNodeA(r2,pbleft) - | _ -> raise jprover_bug - end - | PNodeA(o,PNodeB(rule,left,right)),la -> (* one-over-two *) -(* print_endline " one-over-two "; *) - if rule = r then (* left,right are or_l free *) - permute o rule ptree la tsubrel (* first termination case *) - else - let d = next_direction addr act_addr in - if d = "l" then - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbleft = permute_branch r addr (act_addr^d) left2 dglist (subrel,tsubrel) in - let plright = permute_layer right2 dglist (subrel,tsubrel) in - PNodeB(r2,pbleft,plright) - | _ -> raise jprover_bug - ) - else (* d = "r", that is left of rule is or_l free *) - let left1,bool = weak_modify rule left (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = permute o rule (PNodeA(o,PNodeB(rule,left1,right))) la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbright = permute_branch r addr (act_addr^d) right2 dglist (subrel,tsubrel) in - PNodeB(r2,left2,pbright) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - PNodeA(o,left1) (* optimized termination case (1) *) - | PNodeB(o,PNodeA(rule,left),right1),"l" -> (* two-over-one, left *) -(* print_endline " two-over-one, left "; *) - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeA(r2,left2) -> - let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in - PNodeA(r2,pbleft) - | _ -> raise jprover_bug - ) - | PNodeB(o,left1,PNodeA(rule,left)),"r" -> (* two-over-one, right *) - (* left of o is or_l free *) -(* print_endline " two-over-one, right"; *) - let leftm,bool = weak_modify o left1 (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = permute o rule (PNodeB(o,leftm,PNodeA(rule,left))) la tsubrel in - (match permute_result with - PNodeA(r2,left2) -> - let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in - PNodeA(r2,pbleft) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - leftm (* optimized termination case (2) *) - | PNodeB(o,PNodeB(rule,left,right),right1),"l" -> (* two-over-two, left *) -(* print_endline " two-over-two, left"; *) - if rule = r then (* left,right are or_l free *) - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeB(r2,PNodeB(r3,left3,right3),PNodeB(r4,left4,right4)) -> -(* print_endline "permute 2-o-2, left ok"; *) - let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in - let leftm4,bool4 = weak_modify r4 left4 (subrel,tsubrel) in - let plleft,plright = - if (&) bool3 bool4 then (* r3 and r4 are relevant *) - (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)), - (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel)) - else if (&) bool3 (not bool4) then (* only r3 is relevant *) - begin -(* print_endline "two-over-two left: bool3 and not bool4"; *) - (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)), - leftm4 - end - else if (&) (not bool3) bool4 then (* only r4 is relevant *) - leftm3, - (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel)) - else (* neither r3 nor r4 are relevant *) - leftm3,leftm4 - in - PNodeB(r2,plleft,plright) - | _ -> raise jprover_bug - ) - else - let d = next_direction addr act_addr in - let newadd = change_last act_addr d in - if d = "l" then - let permute_result = permute o rule ptree la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in - let plright = permute_layer right2 dglist (subrel,tsubrel) in - PNodeB(r2,pbleft,plright) - | _ -> raise jprover_bug - ) - else (* d = "r", that is left is or_l free *) - let left1,bool = weak_modify rule left (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = - permute o rule (PNodeB(o,PNodeB(rule,left1,right),right1)) la tsubrel in - (match permute_result with - PNodeB(r2,PNodeB(r3,left3,right3),right2) -> - let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in - let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in - let plleft = - if bool3 (* r3 relevant *) then - permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel) - else (* r3 redundant *) - leftm3 - in - PNodeB(r2,plleft,pbright) (* further opt. NOT possible *) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - permute_layer (PNodeB(o,left1,right1)) dglist (subrel,tsubrel) (* further opt. possible *) - (* combine with orl_free *) - | PNodeB(o,left1,PNodeB(rule,left,right)),"r" -> (* two-over-two, right *) -(* print_endline " two-over-two, right"; *) - let leftm1,bool = weak_modify o left1 (subrel,tsubrel) in (* left1 is or_l free *) - if bool then (* o is relevant, even after permutations *) - if rule = r then (* left, right or_l free *) - permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel - else - let d = next_direction addr act_addr in - let newadd = change_last act_addr d in - if d = "l" then - let permute_result = - permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in - let plright = permute_layer right2 dglist (subrel,tsubrel) in - PNodeB(r2,pbleft,plright) - | _ -> raise jprover_bug - ) - else (* d = "r", that is left is or_l free *) - let leftm,bool = weak_modify rule left (subrel,tsubrel) in - if bool then (* rule is relevant *) - let permute_result = - permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in - (match permute_result with - PNodeB(r2,left2,right2) -> - let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in - PNodeB(r2,left2,pbright) (* left2 or_l free *) - | _ -> raise jprover_bug - ) - else (* rule is not relevant *) - PNodeB(o,leftm1,leftm) - - else - leftm1 - | _ -> raise jprover_bug - in - let rec trans_add_branch r o addr act_addr ptree dglist (subrel,tsubrel) = - match ptree with - (PEmpty| PNodeAx(_)) -> raise jprover_bug - | PNodeA(rule,left) -> - if (dgenerative rule dglist left tsubrel) then - let newdg = (@) [rule] dglist in - if rule = o then - begin -(* print_endline "one-rule is o"; *) - permute_branch r addr act_addr ptree dglist (subrel,tsubrel) - end - else - begin -(* print_endline "alpha - but not o"; *) - let tptree = trans_add_branch r o addr act_addr left newdg (subrel,tsubrel) in - permute_layer (PNodeA(rule,tptree)) dglist (subrel,tsubrel) - (* r may not longer be valid for rule *) - end - else - let tptree = trans_add_branch r o addr act_addr left dglist (subrel,tsubrel) in - PNodeA(rule,tptree) - | PNodeB(rule,left,right) -> - let d = next_direction addr act_addr in - let bool = (dgenerative rule dglist left tsubrel) in - if rule = o then - begin -(* print_endline "two-rule is o"; *) - permute_branch r addr (act_addr^d) ptree dglist (subrel,tsubrel) - end - else - begin -(* print_endline ("beta - but not o: address "^d); *) - let dbranch = - if d = "l" then - left - else (* d = "r" *) - right - in - let tptree = - if bool then - let newdg = (@) [rule] dglist in - (trans_add_branch r o addr (act_addr^d) dbranch newdg (subrel,tsubrel)) - else - (trans_add_branch r o addr (act_addr^d) dbranch dglist (subrel,tsubrel)) - in - if d = "l" then - permute_layer (PNodeB(rule,tptree,right)) dglist (subrel,tsubrel) - else (* d = "r" *) - begin -(* print_endline "prob. a redundant call"; *) - let back = permute_layer (PNodeB(rule,left,tptree)) dglist (subrel,tsubrel) in -(* print_endline "SURELY a redundant call"; *) - back - end - end - in -(* print_endline "permute_layer in"; *) - let dummyt = mk_var_term "dummy" in - let r,o,addr = - top_addmissible_pair ptree dglist ("",Orl,dummyt,dummyt) ("",Orr,dummyt,dummyt) "" tsubrel dummyt in - if r = ("",Orl,dummyt,dummyt) then - ptree - else if o = ("",Orr,dummyt,dummyt) then (* Orr is a dummy for no d-gen. rule *) - ptree - else -(* - let (x1,x2,x3,x4) = r - and (y1,y2,y3,y4) = o in - print_endline ("top or_l: "^x1); - print_endline ("or_l address: "^addr); - print_endline ("top dgen-rule: "^y1); -*) - trans_add_branch r o addr "" ptree dglist (subrel,tsubrel) - -(* Isolate layer and outer recursion structure *) -(* uses weaker layer boundaries: ONLY critical inferences *) - - let rec trans_layer ptree (subrel,tsubrel) = - let rec isol_layer ptree (subrel,tsubrel) = - match ptree with - PEmpty -> raise jprover_bug - | PNodeAx(inf) -> - ptree - | PNodeA((pos,rule,formula,term),left) -> - if List.mem rule [Allr;Impr;Negr] then - let tptree = trans_layer left (subrel,tsubrel) in - PNodeA((pos,rule,formula,term),tptree) - else - let tptree = isol_layer left (subrel,tsubrel) in - PNodeA((pos,rule,formula,term),tptree) - | PNodeB(rule,left,right) -> - let tptree_l = isol_layer left (subrel,tsubrel) - and tptree_r = isol_layer right (subrel,tsubrel) in - PNodeB(rule,tptree_l,tptree_r) - in - begin -(* print_endline "trans_layer in"; *) - let top_tree = isol_layer ptree (subrel,tsubrel) in - let back = permute_layer top_tree [] (subrel,tsubrel) in -(* print_endline "translauer out"; *) - back - end - -(* REAL PERMUTATION STAFF --- End *) - -(* build the proof tree from a list of inference rules *) - - let rec unclosed subtree = - match subtree with - PEmpty -> true - | PNodeAx(y) -> false - | PNodeA(y,left) -> (unclosed left) - | PNodeB(y,left,right) -> (or) (unclosed left) (unclosed right) - - let rec extend prooftree element = - match prooftree with - PEmpty -> - let (pos,rule,formula,term) = element in - if rule = Ax then - PNodeAx(element) - else - if List.mem rule [Andr; Orl; Impl] then - PNodeB(element,PEmpty,PEmpty) - else - PNodeA(element,PEmpty) - | PNodeAx(y) -> - PEmpty (* that's only for exhaustive pattern matching *) - | PNodeA(y, left) -> - PNodeA(y, (extend left element)) - | PNodeB(y, left, right) -> - if (unclosed left) then - PNodeB(y, (extend left element), right) - else - PNodeB(y, left, (extend right element)) - - let rec bptree prooftree nodelist nax= - match nodelist with - [] -> prooftree,nax - | ((_,pos),(rule,formula,term))::rest -> (* kick away the first argument *) - let newax = - if rule = Ax then - 1 - else - 0 - in - bptree (extend prooftree (pos,rule,formula,term)) rest (nax+newax) - - - let bproof nodelist = - bptree PEmpty nodelist 0 - - let rec get_successor_pos treelist = - match treelist with - [] -> [] - | f::r -> - ( - match f with - Empty -> get_successor_pos r - | NodeAt(_) -> raise jprover_bug - | NodeA(pos,_) -> - pos::(get_successor_pos r) - ) - - let rec get_formula_tree ftreelist f predflag = - match ftreelist with - [] -> raise jprover_bug - | ftree::rest_trees -> - (match ftree with - Empty -> get_formula_tree rest_trees f predflag - | NodeAt(_) -> get_formula_tree rest_trees f predflag - | NodeA(pos,suctrees) -> - if predflag = "pred" then - if pos.pt = Gamma then - let succs = get_successor_pos (Array.to_list suctrees) in - if List.mem f succs then - NodeA(pos,suctrees),succs - else - get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag - else - get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag - else (* predflag = "" *) - if pos = f then - NodeA(pos,suctrees),[] - else - get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag - ) - - let rec get_formula_treelist ftree po = - match po with - [] -> [] - | f::r -> -(* a posistion in po has either stype Gamma_0,Psi_0,Phi_0 (non-atomic), or it has *) -(* ptype Alpha (or on the right), since there was a deadlock for proof reconstruction in LJ*) - if List.mem f.st [Phi_0;Psi_0] then - let (stree,_) = get_formula_tree [ftree] f "" in - stree::(get_formula_treelist ftree r) - else - if f.st = Gamma_0 then - let (predtree,succs) = get_formula_tree [ftree] f "pred" in - let new_po = list_diff r succs in - predtree::(get_formula_treelist ftree new_po) - else - if f.pt = Alpha then (* same as first case, or on the right *) - let (stree,_) = get_formula_tree [ftree] f "" in - stree::(get_formula_treelist ftree r) - else raise (Invalid_argument "Jprover bug: non-admissible open position") - - let rec build_formula_rel dir_treelist slist predname = - - let rec build_renamed_gamma_rel dtreelist predname posname d = - match dtreelist with - [] -> [],[] - | (x,ft)::rdtlist -> - let rest_rel,rest_ren = build_renamed_gamma_rel rdtlist predname posname d in - ( - match ft with - Empty -> (* may have empty successors due to purity in former reconstruction steps *) - rest_rel,rest_ren - | NodeAt(_) -> - raise jprover_bug (* gamma_0 position never is atomic *) - | NodeA(spos,suctrees) -> - if List.mem spos.name slist then -(* the gamma_0 position is really unsolved *) -(* this is only relevant for the gamma_0 positions in po *) - let new_name = (posname^"_"^spos.name) (* make new unique gamma name *) in - let new_srel_el = ((predname,new_name),d) - and new_rename_el = (spos.name,new_name) (* gamma_0 position as key first *) in - let (srel,sren) = build_formula_rel [(x,ft)] slist new_name in - ((new_srel_el::srel) @ rest_rel),((new_rename_el::sren) @ rest_ren) - else - rest_rel,rest_ren - ) - - - in - match dir_treelist with - [] -> [],[] - | (d,f)::dir_r -> - let (rest_rel,rest_renlist) = build_formula_rel dir_r slist predname in - match f with - Empty -> - print_endline "Hello, an empty subtree!!!!!!"; - rest_rel,rest_renlist - | NodeAt(pos) -> - (((predname,pos.name),d)::rest_rel),rest_renlist - | NodeA(pos,suctrees) -> - (match pos.pt with - Alpha | Beta -> - let dtreelist = - if (pos.pt = Alpha) & (pos.op = Neg) then - [(1,suctrees.(0))] - else - let st1 = suctrees.(0) - and st2 = suctrees.(1) in - [(1,st1);(2,st2)] - in - let (srel,sren) = build_formula_rel dtreelist slist pos.name in - ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) - | Delta -> - let st1 = suctrees.(0) in - let (srel,sren) = build_formula_rel [(1,st1)] slist pos.name in - ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) - | Psi| Phi -> - let succlist = Array.to_list suctrees in - let dtreelist = (List.map (fun x -> (d,x)) succlist) in - let (srel,sren) = build_formula_rel dtreelist slist predname in - (srel @ rest_rel),(sren @ rest_renlist) - | Gamma -> - let succlist = (Array.to_list suctrees) in - let dtreelist = (List.map (fun x -> (1,x)) succlist) in -(* if (nonemptys suctrees 0 n) = 1 then - let (srel,sren) = build_formula_rel dtreelist slist pos.name in - ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) - else (* we have more than one gamma instance, which means renaming *) -*) - let (srel,sren) = build_renamed_gamma_rel dtreelist predname pos.name d in - (srel @ rest_rel),(sren @ rest_renlist) - | PNull -> - raise jprover_bug - ) - - let rec rename_gamma ljmc_proof rename_list = - match ljmc_proof with - [] -> [] - | ((inst,pos),(rule,formula,term))::r -> - if List.mem rule [Alll;Exr] then - let new_gamma = List.assoc inst rename_list in - ((inst,new_gamma),(rule,formula,term))::(rename_gamma r rename_list) - else - ((inst,pos),(rule,formula,term))::(rename_gamma r rename_list) - - let rec compare_pair (s,sf) list = - if list = [] then - list - else - let (s_1,sf_1),restlist = (List.hd list),(List.tl list) in - if sf = s_1 then - (@) [(s,sf_1)] (compare_pair (s,sf) restlist) - else - compare_pair (s,sf) restlist - - let rec compare_pairlist list1 list2 = - if list1 = [] then - list1 - else - let (s1,sf1),restlist1 = (List.hd list1),(List.tl list1) in - (@) (compare_pair (s1,sf1) list2) (compare_pairlist restlist1 list2) - - let rec trans_rec pairlist translist = - let tlist = compare_pairlist pairlist translist in - if tlist = [] then - translist - else - (@) (trans_rec pairlist tlist) translist - - let transitive_closure subrel = - let pairlist,nlist = List.split subrel in - trans_rec pairlist pairlist - - let pt ptree subrel = - let tsubrel = transitive_closure subrel in - let transptree = trans_layer ptree (subrel,tsubrel) in - print_endline ""; - fst (modify transptree (subrel,tsubrel)) -(* let mtree = fst (modify transptree (subrel,tsubrel)) in *) -(* pretty_print mtree ax *) - - let rec make_node_list ljproof = - match ljproof with - PEmpty -> - raise jprover_bug - | PNodeAx((pos,inf,form,term)) -> - [(("",pos),(inf,form,term))] - | PNodeA((pos,inf,form,term),left) -> - let left_list = make_node_list left in - (("",pos),(inf,form,term))::left_list - | PNodeB((pos,inf,form,term),left,right) -> - let left_list = make_node_list left - and right_list = make_node_list right in - (("",pos),(inf,form,term))::(left_list @ right_list) - - let permute_ljmc ftree po slist ljmc_proof = - (* ftree/po are the formula tree / open positions of the sequent that caused deadlock and permutation *) -(* print_endline "!!!!!!!!!!!!!Permutation TO DO!!!!!!!!!"; *) - (* the open positions in po are either phi_0, psi_0, or gamma_0 positions *) - (* since proof reconstruction was a deadlock in LJ *) - let po_treelist = get_formula_treelist ftree po in - let dir_treelist = List.map (fun x -> (1,x)) po_treelist in - let (formula_rel,rename_list) = build_formula_rel dir_treelist slist "dummy" in - let renamed_ljmc_proof = rename_gamma ljmc_proof rename_list in - let (ptree,ax) = bproof renamed_ljmc_proof in - let ljproof = pt ptree formula_rel in - (* this is a direct formula relation, comprising left/right subformula *) - begin -(* print_treelist po_treelist; *) -(* print_endline ""; - print_endline ""; -*) -(* print_triplelist formula_rel; *) -(* print_endline ""; - print_endline ""; - tt ljproof; -*) -(* print_pairlist rename_list; *) -(* print_endline ""; - print_endline ""; -*) - make_node_list ljproof - end - -(************** PROOF RECONSTRUCTION without redundancy deletion ******************************) - - let rec init_unsolved treelist = - match treelist with - [] -> [] - | f::r -> - begin match f with - Empty -> [] - | NodeAt(pos) -> - (pos.name)::(init_unsolved r) - | NodeA(pos,suctrees) -> - let new_treelist = (Array.to_list suctrees) @ r in - (pos.name)::(init_unsolved new_treelist) - end - -(* only the unsolved positions will be represented --> skip additional root position *) - - let build_unsolved ftree = - match ftree with - Empty | NodeAt _ -> - raise jprover_bug - | NodeA(pos,suctrees) -> - ((pos.name),init_unsolved (Array.to_list suctrees)) - -(* - let rec collect_variables tree_list = - match tree_list with - [] -> [] - | f::r -> - begin match f with - Empty -> [] - | NodeAt(pos) -> - if pos.st = Gamma_0 then - pos.name::collect_variables r - else - collect_variables r - | NodeA(pos,suctrees) -> - let new_tree_list = (Array.to_list suctrees) @ r in - if pos.st = Gamma_0 then - pos.name::collect_variables new_tree_list - else - collect_variables new_tree_list - end - - let rec extend_sigmaQ sigmaQ vlist = - match vlist with - [] -> [] - | f::r -> - let vf = mk_var_term f in - if List.exists (fun x -> (fst x = vf)) sigmaQ then - extend_sigmaQ sigmaQ r - else -(* first and second component are var terms in meta-prl *) - [(vf,vf)] @ (extend_sigmaQ sigmaQ r) - - let build_sigmaQ sigmaQ ftree = - let vlist = collect_variables [ftree] in - sigmaQ @ (extend_sigmaQ sigmaQ vlist) -*) - -(* subformula relation subrel is assumed to be represented in pairs - (a,b) *) - - let rec delete e list = (* e must not necessarily occur in list *) - match list with - [] -> [] (* e must not necessarily occur in list *) - | first::rest -> - if e = first then - rest - else - first::(delete e rest) - - let rec key_delete fname pos_list = (* in key_delete, f is a pos name (key) but sucs is a list of positions *) - match pos_list with - [] -> [] (* the position with name f must not necessarily occur in pos_list *) - | f::r -> - if fname = f.name then - r - else - f::(key_delete fname r) - - let rec get_roots treelist = - match treelist with - [] -> [] - | f::r -> - match f with - Empty -> (get_roots r) (* Empty is posible below alpha-nodes after purity *) - | NodeAt(pos) -> pos::(get_roots r) - | NodeA(pos,trees) -> pos::(get_roots r) - - let rec comp_ps padd ftree = - match ftree with - Empty -> raise (Invalid_argument "Jprover bug: empty formula tree") - | NodeAt(pos) -> - [] - | NodeA(pos,strees) -> - match padd with - [] -> get_roots (Array.to_list strees) - | f::r -> - if r = [] then - pos::(comp_ps r (Array.get strees (f-1))) - else - comp_ps r (Array.get strees (f-1)) - -(* computes a list: first element predecessor, next elements successoes of p *) - - let tpredsucc p ftree = - let padd = p.address in - comp_ps padd ftree - -(* set an element in an array, without side effects *) - - let myset array int element = - let length = Array.length array in - let firstpart = Array.sub array 0 (int) in - let secondpart = Array.sub array (int+1) (length-(int+1)) in - (Array.append firstpart (Array.append [|element|] secondpart)) - - let rec compute_open treelist slist = - match treelist with - [] -> [] - | first::rest -> - let elements = - match first with - Empty -> [] - | NodeAt(pos) -> - if (List.mem (pos.name) slist) then - [pos] - else - [] - | NodeA(pos,suctrees) -> - if (List.mem (pos.name) slist) then - [pos] - else - compute_open (Array.to_list suctrees) slist - in - elements @ (compute_open rest slist) - - let rec select_connection pname connections slist = - match connections with - [] -> ("none","none") - | f::r -> - let partner = - if (fst f) = pname then - (snd f) - else - if (snd f) = pname then - (fst f) - else - "none" - in - if ((partner = "none") or (List.mem partner slist)) then - select_connection pname r slist - else - f - - let rec replace_element element element_set redord = - match redord with - [] -> raise jprover_bug (* element occurs in redord *) - | (f,fset)::r -> - if f = element then - (f,element_set)::r - else - (f,fset)::(replace_element element element_set r) - - let rec collect_succ_sets sucs redord = - match redord with - [] -> StringSet.empty - | (f,fset)::r -> - let new_sucs = key_delete f sucs in - if (List.length sucs) = (List.length new_sucs) then (* position with name f did not occur in sucs -- no deletion *) - (collect_succ_sets sucs r) - else - StringSet.union (StringSet.add f fset) (collect_succ_sets new_sucs r) - - let replace_ordering psucc_name sucs redord = - let new_psucc_set = collect_succ_sets sucs redord in -(* print_string_set new_psucc_set; *) - replace_element psucc_name new_psucc_set redord - - let rec update pname redord = - match redord with - [] -> [] - | (f,fset)::r -> - if pname=f then - r - else - (f,fset)::(update pname r) - -(* rule construction *) - - let rec selectQ_rec spos_var csigmaQ = - match csigmaQ with - [] -> mk_var_term spos_var (* dynamic completion of csigmaQ *) - | (var,term)::r -> - if spos_var=var then - term - else - selectQ_rec spos_var r - - let selectQ spos_name csigmaQ = - let spos_var = spos_name^"_jprover" in - selectQ_rec spos_var csigmaQ - - let apply_sigmaQ term sigmaQ = - let sigma_vars,sigma_terms = List.split sigmaQ in - (subst term sigma_vars sigma_terms) - - let build_rule pos spos csigmaQ orr_flag calculus = - let inst_label = apply_sigmaQ (pos.label) csigmaQ in - match pos.op,pos.pol with - Null,_ -> raise (Invalid_argument "Jprover: no rule") - | At,O -> Ax,(inst_label),xnil_term (* to give back a term *) - | At,I -> Ax,(inst_label),xnil_term - | And,O -> Andr,(inst_label),xnil_term - | And,I -> Andl,(inst_label),xnil_term - | Or,O -> - if calculus = "LJ" then - let or_rule = - if orr_flag = 1 then - Orr1 - else - Orr2 - in - or_rule,(inst_label),xnil_term - else - Orr,(inst_label),xnil_term - | Or,I -> Orl,(inst_label),xnil_term - | Neg,O -> Negr,(inst_label),xnil_term - | Neg,I -> Negl,(inst_label),xnil_term - | Imp,O -> Impr,(inst_label),xnil_term - | Imp,I -> Impl,(inst_label),xnil_term - | All,I -> Alll,(inst_label),(selectQ spos.name csigmaQ) (* elements of csigmaQ is (string * term) *) - | Ex,O -> Exr,(inst_label), (selectQ spos.name csigmaQ) - | All,O -> Allr,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *) - | Ex,I -> Exl,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *) - - -(* %%%%%%%%%%%%%%%%%%%% Split begin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) - - let rec nonemptys treearray j n = - if j = n then - 0 - else - let count = - if (Array.get treearray j) <> Empty then - 1 - else - 0 - in - count + (nonemptys treearray (j+1) n) - - let rec collect_pure ftreelist (flist,slist) = - - let rec collect_itpure ftree (flist,slist) = - match ftree with - Empty -> (* assumed that not all brother trees are Empty *) - [] - | NodeAt(pos) -> (* that may NOT longer be an inner node *) - if ((List.mem (pos.name) flist) or (List.mem (pos.name) slist)) then - [] - else - [pos] - | NodeA(pos,treearray) -> - collect_pure (Array.to_list treearray) (flist,slist) - in - match ftreelist with - [] -> [] - | f::r -> - (collect_itpure f (flist,slist)) @ (collect_pure r (flist,slist)) - - let rec update_list testlist list = - match testlist with - [] -> list - | f::r -> - let newlist = delete f list in (* f may not occur in list; then newlist=list *) - update_list r newlist - - let rec update_pairlist p pairlist = - match pairlist with - [] -> [] - | f::r -> - if ((fst f) = p) or ((snd f) = p) then - update_pairlist p r - else - f::(update_pairlist p r) - - let rec update_connections slist connections = - match slist with - [] -> connections - | f::r -> - let connew = update_pairlist f connections in - update_connections r connew - - let rec update_redord delset redord = (* delset is the set of positions to be deleted *) - match redord with - [] -> [] - | (f,fset)::r -> - if (StringSet.mem f delset) then - update_redord delset r (* delete all key elements f from redord which are in delset *) - else - let new_fset = StringSet.diff fset delset in (* no successor of f from delset should remain in fset *) - (f,new_fset)::(update_redord delset r) - - let rec get_position_names treelist = - match treelist with - [] -> [] - | deltree::rests -> - match deltree with - Empty -> get_position_names rests - | NodeAt(pos) -> - (pos.name)::get_position_names rests - | NodeA(pos,strees) -> - (pos.name)::(get_position_names ((Array.to_list strees) @ rests)) - - let rec slist_to_set slist = - match slist with - [] -> - StringSet.empty - | f::r -> - StringSet.add f (slist_to_set r) - - let rec print_purelist pr = - match pr with - [] -> - begin - print_string "."; - print_endline " "; - end - | f::r -> - print_string ((f.name)^", "); - print_purelist r - - let update_relations deltree redord connections unsolved_list = - let pure_names = get_position_names [deltree] in - begin -(* print_ftree deltree; - Format.open_box 0; - print_endline " "; - print_stringlist pure_names; - Format.force_newline (); - Format.print_flush (); -*) - let rednew = update_redord (slist_to_set pure_names) redord - and connew = update_connections pure_names connections - and unsolnew = update_list pure_names unsolved_list in - (rednew,connew,unsolnew) - end - - let rec collect_qpos ftreelist uslist = - match ftreelist with - [] -> [],[] - | ftree::rest -> - match ftree with - Empty -> - collect_qpos rest uslist - | NodeAt(pos) -> - let (rest_delta,rest_gamma) = collect_qpos rest uslist in - if (pos.st = Gamma_0) & (List.mem pos.name uslist) then - rest_delta,(pos.name::rest_gamma) - else - if (pos.st = Delta_0) & (List.mem pos.name uslist) then - (pos.name::rest_delta),rest_gamma - else - rest_delta,rest_gamma - | NodeA(pos,suctrees) -> - let (rest_delta,rest_gamma) = collect_qpos ((Array.to_list suctrees) @ rest) uslist in - if (pos.st = Gamma_0) & (List.mem pos.name uslist) then - rest_delta,(pos.name::rest_gamma) - else - if (pos.st = Delta_0) & (List.mem pos.name uslist) then - (pos.name::rest_delta),rest_gamma - else - rest_delta,rest_gamma - - let rec do_split gamma_diff sigmaQ = - match sigmaQ with - [] -> [] - | (v,term)::r -> - if (List.mem (String.sub v 0 (String.index v '_')) gamma_diff) then - do_split gamma_diff r - else - (v,term)::(do_split gamma_diff r) - -(* make a term list out of a bterm list *) - - let rec collect_subterms = function - [] -> [] - | bt::r -> - let dbt = dest_bterm bt in - (dbt.bterm)::(collect_subterms r) - - let rec collect_delta_terms = function - [] -> [] - | t::r -> - let dt = dest_term t in - let top = dt.term_op - and tterms = dt.term_terms in - let dop = dest_op top in - let don = dest_opname dop.op_name in - let doa = dest_param dop.op_params in - match don with - [] -> - let sub_terms = collect_subterms tterms in - collect_delta_terms (sub_terms @ r) - | op1::opr -> - if op1 = "jprover" then - match doa with - [] -> raise (Invalid_argument "Jprover: delta position missing") - | String delta::_ -> - delta::(collect_delta_terms r) - | _ -> raise (Invalid_argument "Jprover: delta position error") - else - let sub_terms = collect_subterms tterms in - collect_delta_terms (sub_terms @ r) - - - - let rec check_delta_terms (v,term) ass_delta_diff dterms = - match ass_delta_diff with - [] -> term,[] - | (var,dname)::r -> - if List.mem dname dterms then - let new_var = - if var = "" then - v - else - var - in - let replace_term = mk_string_term jprover_op dname in - let next_term = var_subst term replace_term new_var in - let (new_term,next_diffs) = check_delta_terms (v,next_term) r dterms in - (new_term,((new_var,dname)::next_diffs)) - else - let (new_term,next_diffs) = check_delta_terms (v,term) r dterms in - (new_term,((var,dname)::next_diffs)) - - - let rec localize_sigma zw_sigma ass_delta_diff = - match zw_sigma with - [] -> [] - | (v,term)::r -> - let dterms = collect_delta_terms [term] in - let (new_term,new_ass_delta_diff) = check_delta_terms (v,term) ass_delta_diff dterms in - (v,new_term)::(localize_sigma r new_ass_delta_diff) - - let subst_split ft1 ft2 ftree uslist1 uslist2 uslist sigmaQ = - let delta,gamma = collect_qpos [ftree] uslist - and delta1,gamma1 = collect_qpos [ft1] uslist1 - and delta2,gamma2 = collect_qpos [ft2] uslist2 in - let delta_diff1 = list_diff delta delta1 - and delta_diff2 = list_diff delta delta2 - and gamma_diff1 = list_diff gamma gamma1 - and gamma_diff2 = list_diff gamma gamma2 in - let zw_sigma1 = do_split gamma_diff1 sigmaQ - and zw_sigma2 = do_split gamma_diff2 sigmaQ in - let ass_delta_diff1 = List.map (fun x -> ("",x)) delta_diff1 - and ass_delta_diff2 = List.map (fun x -> ("",x)) delta_diff2 in - let sigmaQ1 = localize_sigma zw_sigma1 ass_delta_diff1 - and sigmaQ2 = localize_sigma zw_sigma2 ass_delta_diff2 in - (sigmaQ1,sigmaQ2) - - let rec reduce_tree addr actual_node ftree beta_flag = - match addr with - [] -> (ftree,Empty,actual_node,beta_flag) - | a::radd -> - match ftree with - Empty -> - print_endline "Empty purity tree"; - raise jprover_bug - | NodeAt(_) -> - print_endline "Atom purity tree"; - raise jprover_bug - | NodeA(pos,strees) -> -(* print_endline pos.name; *) - (* the associated node occurs above f (or the empty address) and hence, is neither atom nor empty tree *) - - let nexttree = (Array.get strees (a-1)) in - if (nonemptys strees 0 (Array.length strees)) < 2 then - begin -(* print_endline "strees 1 or non-empties < 2"; *) - let (ft,dt,an,bf) = reduce_tree radd actual_node nexttree beta_flag in - let nstrees = myset strees (a-1) ft in -(* print_endline ("way back "^pos.name); *) - (NodeA(pos,nstrees),dt,an,bf) - end - else (* nonemptys >= 2 *) - begin -(* print_endline "nonempties >= 2 "; *) - let (new_act,new_bf) = - if pos.pt = Beta then - (actual_node,true) - else - ((pos.name),false) - in - let (ft,dt,an,bf) = reduce_tree radd new_act nexttree new_bf in - if an = pos.name then - let nstrees = myset strees (a-1) Empty in -(* print_endline ("way back assocnode "^pos.name); *) - (NodeA(pos,nstrees),nexttree,an,bf) - else (* has been replaced / will be replaced below / above pos *) - let nstrees = myset strees (a-1) ft in -(* print_endline ("way back "^pos.name); *) - (NodeA(pos,nstrees),dt,an,bf) - end - - let rec purity ftree redord connections unsolved_list = - - let rec purity_reduction pr ftree redord connections unsolved_list = - begin -(* Format.open_box 0; - print_endline " "; - print_purelist pr; - Format.force_newline (); - Format.print_flush (); -*) - match pr with - [] -> (ftree,redord,connections,unsolved_list) - | f::r -> -(* print_endline ("pure position "^(f.name)); *) - let (ftnew,deltree,assocn,beta_flag) = reduce_tree f.address "" ftree false - in -(* print_endline ("assoc node "^assocn); *) - if assocn = "" then - (Empty,[],[],[]) (* should not occur in the final version *) - else - let (rednew,connew,unsolnew) = update_relations deltree redord connections unsolved_list in - begin -(* Format.open_box 0; - print_endline " "; - print_pairlist connew; - Format.force_newline (); - Format.print_flush (); -*) - if beta_flag = true then - begin -(* print_endline "beta_flag true"; *) - purity ftnew rednew connew unsolnew - (* new pure positions may occur; old ones may not longer exist *) - end - else - purity_reduction r ftnew rednew connew unsolnew (* let's finish the old pure positions *) - end - end - - in - let flist,slist = List.split connections in - let pr = collect_pure [ftree] (flist,slist) in - purity_reduction pr ftree redord connections unsolved_list - - let rec betasplit addr ftree redord connections unsolved_list = - match ftree with - Empty -> - print_endline "bsplit Empty tree"; - raise jprover_bug - | NodeAt(_) -> - print_endline "bsplit Atom tree"; - raise jprover_bug (* the beta-node should actually occur! *) - | NodeA(pos,strees) -> - match addr with - [] -> (* we are at the beta node under consideration *) - let st1tree = (Array.get strees 0) - and st2tree = (Array.get strees 1) in - let (zw1red,zw1conn,zw1uslist) = update_relations st2tree redord connections unsolved_list - and (zw2red,zw2conn,zw2uslist) = update_relations st1tree redord connections unsolved_list in - ((NodeA(pos,[|st1tree;Empty|])),zw1red,zw1conn,zw1uslist), - ((NodeA(pos,[|Empty;st2tree|])),zw2red,zw2conn,zw2uslist) - | f::rest -> - let nexttree = Array.get strees (f-1) in - let (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) = - betasplit rest nexttree redord connections unsolved_list in -(* let scopytrees = Array.copy strees in *) - let zw1trees = myset strees (f-1) zw1ft - and zw2trees = myset strees (f-1) zw2ft in - (NodeA(pos,zw1trees),zw1red,zw1conn,zw1uslist),(NodeA(pos,zw2trees),zw2red,zw2conn,zw2uslist) - - - - - let split addr pname ftree redord connections unsolved_list opt_bproof = - let (opt_bp1,min_con1),(opt_bp2,min_con2) = split_permutation pname opt_bproof in - begin -(* - print_endline "Beta proof 1: "; - print_endline ""; - print_beta_proof opt_bp1; - print_endline ""; - print_endline ("Beta proof 1 connections: "); - Format.open_box 0; - print_pairlist min_con1; - print_endline "."; - Format.print_flush(); - print_endline ""; - print_endline ""; - print_endline "Beta proof 2: "; - print_endline ""; - print_beta_proof opt_bp2; - print_endline ""; - print_endline ("Beta proof 2 connections: "); - Format.open_box 0; - print_pairlist min_con2; - print_endline "."; - Format.print_flush(); - print_endline ""; -*) - let (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) = - betasplit addr ftree redord connections unsolved_list in -(* zw1conn and zw2conn are not longer needed when using beta proofs *) -(* print_endline "betasp_out"; *) - let ft1,red1,conn1,uslist1 = purity zw1ft zw1red min_con1 zw1uslist in -(* print_endline "purity_one_out"; *) - let ft2,red2,conn2,uslist2 = purity zw2ft zw2red min_con2 zw2uslist in -(* print_endline "purity_two_out"; *) -(* again, min_con1 = conn1 and min_con2 = conn2 should hold *) - begin -(* print_endline ""; - print_endline ""; - print_endline ("Purity 1 connections: "); - Format.open_box 0; - print_pairlist conn1; - print_endline "."; - print_endline ""; - Format.print_flush(); - print_endline ""; - print_endline ""; - print_endline ("Purity 2 connections: "); - Format.open_box 0; - print_pairlist conn2; - print_endline "."; - print_endline ""; - Format.print_flush(); - print_endline ""; - print_endline ""; -*) - (ft1,red1,conn1,uslist1,opt_bp1),(ft2,red2,conn2,uslist2,opt_bp2) - end - end - - -(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Splitting end %%%%%%%%%%%%%%%% *) - - -(* for wait labels we collect all solved atoms with pol=0 *) - - let rec collect_solved_O_At ftreelist slist = - match ftreelist with - [] -> - [] - | f::r -> - match f with - Empty -> (* may become possible after purity *) - collect_solved_O_At r slist - | NodeAt(pos) -> - if ((List.mem (pos.name) slist) or (pos.pol = I)) then (* recall slist is the unsolved list *) - collect_solved_O_At r slist - else - (* here, we have pos solved and pos.pol = O) *) - pos::(collect_solved_O_At r slist) - | NodeA(pos,treearray) -> - collect_solved_O_At ((Array.to_list treearray) @ r) slist - - let rec red_ord_block pname redord = - match redord with - [] -> false - | (f,fset)::r -> - if ((f = pname) or (not (StringSet.mem pname fset))) then - red_ord_block pname r - else - true (* then, we have (StringSet.mem pname fset) *) - - let rec check_wait_succ_LJ faddress ftree = - match ftree with - Empty -> raise jprover_bug - | NodeAt(pos) -> raise jprover_bug (* we have an gamma_0 position or an or-formula *) - | NodeA(pos,strees) -> - match faddress with - [] -> - if pos.op = Or then - match (strees.(0),strees.(1)) with - (Empty,Empty) -> raise (Invalid_argument "Jprover: redundancies occur") - | (Empty,_) -> (false,2) (* determines the Orr2 rule *) - | (_,Empty) -> (false,1) (* determines the Orr1 ruke *) - | (_,_) -> (true,0) (* wait-label is set *) - else - (false,0) - | f::r -> - if r = [] then - if (pos.pt = Gamma) & ((nonemptys strees 0 (Array.length strees)) > 1) then - (true,0) (* we are at a gamma position (exr) with one than one successor -- wait label in LJ*) - else - check_wait_succ_LJ r (Array.get strees (f-1)) - else - check_wait_succ_LJ r (Array.get strees (f-1)) - - let blocked f po redord ftree connections slist logic calculus opt_bproof = -(* print_endline ("Blocking check "^(f.name)); *) - if (red_ord_block (f.name) redord) then - begin -(* print_endline "wait-1 check positive"; *) - true,0 - end - else - if logic = "C" then - false,0 (* ready, in C only redord counts *) - else - let pa_O = collect_solved_O_At [ftree] slist (* solved atoms in ftree *) - and po_test = (delete f po) in - if calculus = "LJmc" then (* we provide dynamic wait labels for both sequent calculi *) -(* print_endline "wait-2 check"; *) - if (f.st = Psi_0) & (f.pt <> PNull) & - ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test)) then - begin -(* print_endline "wait-2 positive"; *) - true,0 (* wait_2 label *) - end - else - begin -(* print_endline "wait-2 negative"; *) - false,0 - end - else (* calculus is supposed to be LJ *) - if calculus = "LJ" then - if ((f.st = Phi_0) & ((f.op=Neg) or (f.op=Imp)) & - ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test)) - ) - (* this would cause an impl or negl rule with an non-empty succedent *) - then - if (f.op=Neg) then - true,0 - else (* (f.op=Imp) *) - (* In case of an impl rule on A => B, the wait_label must NOT be set - iff all succedent formulae depend exclusively on B. For this, we - perform a split operation and determine, if in the A-subgoal - all succedent formulae are pure, i.e.~have been deleted from treds. - Otherwise, in case of A-dependent succedent formulae, the - wait_label must be set. - *) - let ((_,min_con1),_) = split_permutation f.name opt_bproof in - let slist_fake = delete f.name slist in - let ((zw1ft,zw1red,_,zw1uslist),_) = - betasplit (f.address) ftree redord connections slist_fake in - let ft1,_,_,uslist1 = purity zw1ft zw1red min_con1 zw1uslist in -(* print_endline "wait label purity_one_out"; *) - let ft1_root = (List.hd (List.tl (tpredsucc f ft1))) in -(* print_endline ("wait-root "^(ft1_root.name)); *) - let po_fake = compute_open [ft1] uslist1 in - let po_fake_test = delete ft1_root po_fake - and pa_O_fake = collect_solved_O_At [ft1] uslist1 in -(* print_purelist (po_fake_test @ pa_O_fake); *) - if ((pa_O_fake <> []) or (List.exists (fun x -> x.pol = O) po_fake_test)) then - true,0 - else - false,0 - else - if ((f.pol=O) & ((f.st=Gamma_0) or (f.op=Or))) then - let (bool,orr_flag) = check_wait_succ_LJ f.address ftree in - (bool,orr_flag) - (* here is determined if orr1 or orr2 will be performed, provided bool=false) *) - (* orr_flag can be 1 or 2 *) - else - false,0 - else - raise (Invalid_argument "Jprover: calculus should be LJmc or LJ") - - let rec get_beta_preference list actual = - match list with - [] -> actual - | (f,int)::r -> - if f.op = Imp then - (f,int) - else -(* if f.op = Or then - get_beta_preference r (f,int) - else -*) - get_beta_preference r actual - - exception Gamma_deadlock - - let rec select_pos search_po po redord ftree connections slist logic calculus candidates - opt_bproof = - match search_po with - [] -> - (match candidates with - [] -> - if calculus = "LJ" then - raise Gamma_deadlock (* permutation may be necessary *) - else - raise (Invalid_argument "Jprover bug: overall deadlock") (* this case should not occur *) - | c::rest -> - get_beta_preference (c::rest) c - ) - | f::r -> (* there exist an open position *) - let (bool,orr_flag) = (blocked f po redord ftree connections slist logic calculus - opt_bproof) - in - if (bool = true) then - select_pos r po redord ftree connections slist logic calculus candidates opt_bproof - else - if f.pt = Beta then - (* search for non-splitting rules first *) -(* let beta_candidate = - if candidates = [] - then - [(f,orr_flag)] - else - !!!! but preserve first found candidate !!!!!!! - candidates - in - !!!!!!! this strategy is not sure the best -- back to old !!!!!!!!! -*) - select_pos r po redord ftree connections slist logic calculus - ((f,orr_flag)::candidates) opt_bproof - else - (f,orr_flag) - -(* let rec get_position_in_tree pname treelist = - match treelist with - [] -> raise jprover_bug - | f::r -> - begin match f with - Empty -> get_position_in_tree pname r - | NodeAt(pos) -> - if pos.name = pname then - pos - else - get_position_in_tree pname r - | NodeA(pos,suctrees) -> - get_position_in_tree pname ((Array.to_list suctrees) @ r) - end -*) - -(* total corresponds to tot in the thesis, - tot simulates the while-loop, solve is the rest *) - - let rec total ftree redord connections csigmaQ slist logic calculus opt_bproof = - let rec tot ftree redord connections po slist = - let rec solve ftree redord connections p po slist (pred,succs) orr_flag = - let newslist = delete (p.name) slist in - let rback = - if p.st = Gamma_0 then - begin -(* print_endline "that's the gamma rule"; *) - [((p.name,pred.name),(build_rule pred p csigmaQ orr_flag calculus))] - end - else - [] - in -(* print_endline "gamma check finish"; *) - let pnew = - if p.pt <> Beta then - succs @ (delete p po) - else - po - in - match p.pt with - Gamma -> - rback @ (tot ftree redord connections pnew newslist) - | Psi -> - if p.op = At then - let succ = List.hd succs in - rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag) (* solve atoms immediately *) - else - rback @ (tot ftree redord connections pnew newslist) - | Phi -> - if p.op = At then - let succ = List.hd succs in - rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag) (* solve atoms immediately *) - else - rback @ (tot ftree redord connections pnew newslist) - | PNull -> - let new_redord = update p.name redord in - let (c1,c2) = select_connection (p.name) connections newslist in - if (c1= "none" & c2 ="none") then - rback @ (tot ftree new_redord connections pnew newslist) - else - let (ass_pos,inst_pos) = -(* need the pol=O position ass_pos of the connection for later permutation *) -(* need the pol=I position inst_pos for NuPRL instantiation *) - if p.name = c1 then - if p.pol = O then - (c1,c2) - else - (c2,c1) - else (* p.name = c2 *) - if p.pol = O then - (c2,c1) - else - (c1,c2) - in - rback @ [(("",ass_pos),(build_rule p p csigmaQ orr_flag calculus))] - (* one possibility of recursion end *) - | Alpha -> - rback @ ((("",p.name),(build_rule p p csigmaQ orr_flag calculus))::(tot ftree redord connections pnew newslist)) - | Delta -> - let sp = List.hd succs in - rback @ ((("",p.name),(build_rule p sp csigmaQ orr_flag calculus))::(tot ftree redord connections pnew newslist)) - | Beta -> -(* print_endline "split_in"; *) - let (ft1,red1,conn1,uslist1,opt_bproof1),(ft2,red2,conn2,uslist2,opt_bproof2) = - split (p.address) (p.name) ftree redord connections newslist opt_bproof in - let (sigmaQ1,sigmaQ2) = subst_split ft1 ft2 ftree uslist1 uslist2 newslist csigmaQ in -(* print_endline "split_out"; *) - let p1 = total ft1 red1 conn1 sigmaQ1 uslist1 logic calculus opt_bproof1 in -(* print_endline "compute p1 out"; *) - let p2 = total ft2 red2 conn2 sigmaQ2 uslist2 logic calculus opt_bproof2 in -(* print_endline "compute p2 out"; *) - rback @ [(("",p.name),(build_rule p p csigmaQ orr_flag calculus))] @ p1 @ p2 (* second possibility of recursion end *) - in - begin try - let (p,orr_flag) = select_pos po po redord ftree connections slist logic - calculus [] opt_bproof - (* last argument for guiding selection strategy *) - in -(* print_endline ((p.name)^" "^(string_of_int orr_flag)); *) - let predsuccs = tpredsucc p ftree in - let pred = List.hd predsuccs - and succs = List.tl predsuccs in - let redpo = update (p.name) redord in (* deletes the entry (p,psuccset) from the redord *) - let rednew = - if (p.pt = Delta) then (* keep the tree ordering for the successor position only *) - let psucc = List.hd succs in - let ppsuccs = tpredsucc psucc ftree in - let sucs = List.tl ppsuccs in - replace_ordering (psucc.name) sucs redpo (* union the succsets of psucc *) - else - redpo - in -(* print_endline "update ok"; *) - solve ftree rednew connections p po slist (pred,succs) orr_flag - with Gamma_deadlock -> - let ljmc_subproof = total ftree redord connections csigmaQ slist "J" "LJmc" opt_bproof - in - eigen_counter := 1; - permute_ljmc ftree po slist ljmc_subproof - (* the permuaiton result will be appended to the lj proof constructed so far *) - end - in - let po = compute_open [ftree] slist in - tot ftree redord connections po slist - - let reconstruct ftree redord sigmaQ ext_proof logic calculus = - let min_connections = remove_dups_connections ext_proof in - let (opt_bproof,beta_exp,closures) = construct_opt_beta_proof ftree ext_proof in -(* let connections = remove_dups_connections ext_proof in - let bproof,beta_exp,closures = construct_beta_proof ftree connections in - let (opt_bproof,min_connections) = bproof_purity bproof in -*) - if !debug_jprover then - begin - print_endline ""; - print_endline ("Beta proof with number of closures = "^(string_of_int closures)^" and number of beta expansions = "^(string_of_int beta_exp)); -(* print_endline ""; - print_endline ""; - print_beta_proof bproof; - print_endline ""; - print_endline ""; - print_endline "Optimal beta proof: "; - print_endline ""; - print_endline ""; - print_beta_proof opt_bproof; - print_endline ""; - print_endline ""; - print_endline ("Beta proof connections: "); - Format.open_box 0; - print_pairlist min_connections; - print_endline "."; - Format.print_flush(); *) - print_endline ""; - end; - let (newroot_name,unsolved_list) = build_unsolved ftree in - let redord2 = (update newroot_name redord) in (* otherwise we would have a deadlock *) - let (init_tree,init_redord,init_connections,init_unsolved_list) = - purity ftree redord2 min_connections unsolved_list in - begin -(* print_endline ""; - print_endline ""; - print_endline ("Purity connections: "); - Format.open_box 0; - print_pairlist init_connections; - print_endline "."; - print_endline ""; - Format.print_flush(); - print_endline ""; - print_endline ""; -*) -(* it should hold: min_connections = init_connections *) - total init_tree init_redord init_connections sigmaQ - init_unsolved_list logic calculus opt_bproof - end - -(* ***************** REDUCTION ORDERING -- both types **************************** *) - - exception Reflexive - - let rec transitive_irreflexive_closure addset const ordering = - match ordering with - [] -> - [] - | (pos,fset)::r -> - if (pos = const) or (StringSet.mem const fset) then -(* check reflexsivity during transitive closure wrt. addset ONLY!!! *) - if StringSet.mem pos addset then - raise Reflexive - else - (pos,(StringSet.union fset addset))::(transitive_irreflexive_closure addset const r) - else - (pos,fset)::(transitive_irreflexive_closure addset const r) - - let rec search_set var ordering = -(* print_endline var; *) - match ordering with - [] -> - raise (Invalid_argument "Jprover: element in ordering missing") - | (pos,fset)::r -> - if pos = var then - StringSet.add pos fset - else - search_set var r - - let add_sets var const ordering = - let addset = search_set var ordering in - transitive_irreflexive_closure addset const ordering - -(* ************* J ordering ********************************************** *) - - let rec add_arrowsJ (v,vlist) ordering = - match vlist with - [] -> ordering - | f::r -> - if ((String.get f 0)='c') then - let new_ordering = add_sets v f ordering in - add_arrowsJ (v,r) new_ordering - else - add_arrowsJ (v,r) ordering - - let rec add_substJ replace_vars replace_string ordering atom_rel = - match replace_vars with - [] -> ordering - | v::r -> - if (String.get v 1 = 'n') (* don't integrate new variables *) - or (List.exists (fun (x,_,_) -> (x.aname = v)) atom_rel) then (* no reduction ordering at atoms *) - (add_substJ r replace_string ordering atom_rel) - else - let next_ordering = add_arrowsJ (v,replace_string) ordering in - (add_substJ r replace_string next_ordering atom_rel) - - let build_orderingJ replace_vars replace_string ordering atom_rel = - try - add_substJ replace_vars replace_string ordering atom_rel - with Reflexive -> (* only possible in the FO case *) - raise Not_unifiable (*search for alternative string unifiers *) - - let rec build_orderingJ_list substJ ordering atom_rel = - match substJ with - [] -> ordering - | (v,vlist)::r -> - let next_ordering = build_orderingJ [v] vlist ordering atom_rel in - build_orderingJ_list r next_ordering atom_rel - -(* ************* J ordering END ********************************************** *) - -(* ************* quantifier ordering ********************************************** *) - - let rec add_arrowsQ v clist ordering = - match clist with - [] -> ordering - | f::r -> - let new_ordering = add_sets v f ordering in - add_arrowsQ v r new_ordering - - let rec print_sigmaQ sigmaQ = - match sigmaQ with - [] -> - print_endline "." - | (v,term)::r -> - begin - Format.open_box 0; - print_endline " "; - print_string (v^" = "); - print_term stdout term; - Format.force_newline (); - Format.print_flush (); - print_sigmaQ r - end - - let rec print_term_list tlist = - match tlist with - [] -> print_string "." - | t::r -> - begin - print_term stdout t; - print_string " "; - print_term_list r - end - - let rec add_sigmaQ new_elements ordering = - match new_elements with - [] -> ([],ordering) - | (v,termlist)::r -> - let dterms = collect_delta_terms termlist in - begin - let new_ordering = add_arrowsQ v dterms ordering in - let (rest_pairs,rest_ordering) = add_sigmaQ r new_ordering in - ((v,dterms)::rest_pairs),rest_ordering - end - - let build_orderingQ new_elements ordering = -(* new_elements is of type (string * term list) list, since one variable can receive more than *) -(* a single term due to substitution multiplication *) - try -(* print_endline "build orderingQ in"; *) (* apple *) - add_sigmaQ new_elements ordering; - with Reflexive -> - raise Failed (* new connection, please *) - - -(* ************* quantifier ordering END ********************************************** *) - -(* ****** Quantifier unification ************** *) - -(* For multiplication we assume always idempotent substitutions sigma, tau! *) - - let rec collect_assoc inst_vars tauQ = - match inst_vars with - [] -> [] - | f::r -> - let f_term = List.assoc f tauQ in - f_term::(collect_assoc r tauQ) - - let rec rec_apply sigmaQ tauQ tau_vars tau_terms = - match sigmaQ with - [] -> [],[] - | (v,term)::r -> - let app_term = subst term tau_vars tau_terms in - let old_free = free_vars_list term - and new_free = free_vars_list app_term in - let inst_vars = list_diff old_free new_free in - let inst_terms = collect_assoc inst_vars tauQ in - let (rest_sigma,rest_sigma_ordering) = rec_apply r tauQ tau_vars tau_terms in - if inst_terms = [] then - ((v,app_term)::rest_sigma),rest_sigma_ordering - else - let ordering_v = String.sub v 0 (String.index v '_') in - ((v,app_term)::rest_sigma),((ordering_v,inst_terms)::rest_sigma_ordering) - -(* let multiply sigmaQ tauQ = - let tau_vars,tau_terms = List.split tauQ - and sigma_vars,sigma_terms = List.split sigmaQ in - let apply_terms = rec_apply sigma_terms tau_vars tau_terms in - (List.combine sigma_vars apply_terms) @ tauQ -*) - - let multiply sigmaQ tauQ = - let (tau_vars,tau_terms) = List.split tauQ in - let (new_sigmaQ,sigma_ordering) = rec_apply sigmaQ tauQ tau_vars tau_terms in - let tau_ordering_terms = (List.map (fun x -> [x]) tau_terms) (* for extending ordering_elements *) in - let tau_ordering_vars = (List.map (fun x -> String.sub x 0 (String.index x '_')) tau_vars) in - let tau_ordering = (List.combine tau_ordering_vars tau_ordering_terms) in - ((new_sigmaQ @ tauQ), - (sigma_ordering @ tau_ordering) - ) - - let apply_2_sigmaQ term1 term2 sigmaQ = - let sigma_vars,sigma_terms = List.split sigmaQ in - (subst term1 sigma_vars sigma_terms),(subst term2 sigma_vars sigma_terms) - - let jqunify term1 term2 sigmaQ = - let app_term1,app_term2 = apply_2_sigmaQ term1 term2 sigmaQ in - try - let tauQ = unify_mm app_term1 app_term2 StringSet.empty in - let (mult,oel) = multiply sigmaQ tauQ in - (mult,oel) - with - RefineError _ -> (* any unification failure *) -(* print_endline "fo-unification fail"; *) - raise Failed (* new connection, please *) - -(* ************ T-STRING UNIFICATION ******************************** *) - - let rec combine subst (ov,oslist) = - match subst with - [] -> [],[] - | f::r -> - let (v,slist) = f in - let rest_vlist,rest_combine = (combine r (ov,oslist)) in - if (List.mem ov slist) then (* subst assumed to be idemponent *) - let com_element = com_subst slist (ov,oslist) in - (v::rest_vlist),((v,com_element)::rest_combine) - else - (rest_vlist,(f::rest_combine)) - - let compose sigma one_subst = - let (n,subst)=sigma - and (ov,oslist) = one_subst in - let (trans_vars,com) = combine subst (ov,oslist) - in -(* begin - print_endline "!!!!!!!!!test print!!!!!!!!!!"; - print_subst [one_subst]; - print_subst subst; - print_endline "!!!!!!!!! END test print!!!!!!!!!!"; -*) - if List.mem one_subst subst then - (trans_vars,(n,com)) - else -(* ov may multiply as variable in subst with DIFFERENT values *) -(* in order to avoid explicit atom instances!!! *) - (trans_vars,(n,(com @ [one_subst]))) -(* end *) - - let rec apply_element fs ft (v,slist) = - match (fs,ft) with - ([],[]) -> - ([],[]) - | ([],(ft_first::ft_rest)) -> - let new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in - (emptylist,(new_ft_first @ new_ft_rest)) - | ((fs_first::fs_rest),[]) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - in - let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in - ((new_fs_first @ new_fs_rest),emptylist) - | ((fs_first::fs_rest),(ft_first::ft_rest)) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - and new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in - ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest)) - - let rec shorten us ut = - match (us,ut) with - ([],_) -> (us,ut) - | (_,[]) -> (us,ut) - | ((fs::rs),(ft::rt)) -> - if fs = ft then - shorten rs rt - else - (us,ut) - - let rec apply_subst_list eq_rest (v,slist) = - - match eq_rest with - [] -> - (true,[]) - | (atomnames,(fs,ft))::r -> - let (n_fs,n_ft) = apply_element fs ft (v,slist) in - let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *) - match (new_fs,new_ft) with - [],[] -> - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],[]))::new_eq_rest)) - | [],(fft::rft) -> - if (is_const fft) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],new_ft))::new_eq_rest)) - | (ffs::rfs),[] -> - if (is_const ffs) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,[]))::new_eq_rest)) - | (ffs::rfs),(fft::rft) -> - if (is_const ffs) & (is_const fft) then - (false,[]) - (* different first constants cause local fail *) - else - (* at least one of firsts is a variable *) - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,new_ft))::new_eq_rest)) - - let apply_subst eq_rest (v,slist) atomnames = - if (List.mem v atomnames) then (* don't apply subst to atom variables !! *) - (true,eq_rest) - else - apply_subst_list eq_rest (v,slist) - - let all_variable_check eqlist = false (* needs some discussion with Jens! -- NOT done *) - -(* - let rec all_variable_check eqlist = - match eqlist with - [] -> true - | ((_,(fs,ft))::rest_eq) -> - if (fs <> []) & (ft <> []) then - let fs_first = List.hd fs - and ft_first = List.hd ft - in - if (is_const fs_first) or (is_const ft_first) then - false - else - all_variable_check rest_eq - else - false -*) - - let rec tunify_list eqlist init_sigma orderingQ atom_rel = - - let rec tunify atomnames fs ft rt rest_eq sigma ordering = - - let apply_r1 fs ft rt rest_eq sigma = -(* print_endline "r1"; *) - tunify_list rest_eq sigma ordering atom_rel - - in - let apply_r2 fs ft rt rest_eq sigma = -(* print_endline "r2"; *) - tunify atomnames rt fs ft rest_eq sigma ordering - - in - let apply_r3 fs ft rt rest_eq sigma = -(* print_endline "r3"; *) - let rfs = (List.tl fs) - and rft = (List.tl rt) in - tunify atomnames rfs ft rft rest_eq sigma ordering - - in - let apply_r4 fs ft rt rest_eq sigma = -(* print_endline "r4"; *) - tunify atomnames rt ft fs rest_eq sigma ordering - - in - let apply_r5 fs ft rt rest_eq sigma = -(* print_endline "r5"; *) - let v = (List.hd fs) in - let (compose_vars,new_sigma) = compose sigma (v,ft) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in - if (bool=false) then - raise Not_unifiable - else - let new_ordering = build_orderingJ (v::compose_vars) ft ordering atom_rel in - tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma new_ordering - - in - let apply_r6 fs ft rt rest_eq sigma = -(* print_endline "r6"; *) - let v = (List.hd fs) in - let (_,new_sigma) = (compose sigma (v,[])) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in - if (bool=false) then - raise Not_unifiable - else - (* no relation update since [] has been replaced for v *) - tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma ordering - - in - let apply_r7 fs ft rt rest_eq sigma = -(* print_endline "r7"; *) - let v = (List.hd fs) - and c1 = (List.hd rt) - and c2t =(List.tl rt) in - let (compose_vars,new_sigma) = (compose sigma (v,(ft @ [c1]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in - if bool=false then - raise Not_unifiable - else - let new_ordering = build_orderingJ (v::compose_vars) (ft @ [c1]) ordering atom_rel in - tunify atomnames (List.tl fs) [] c2t new_rest_eq new_sigma new_ordering - - - in - let apply_r8 fs ft rt rest_eq sigma = -(* print_endline "r8"; *) - tunify atomnames rt [(List.hd fs)] (List.tl fs) rest_eq sigma ordering - - in - let apply_r9 fs ft rt rest_eq sigma = -(* print_endline "r9"; *) - let v = (List.hd fs) - and (max,subst) = sigma in - let v_new = ("vnew"^(string_of_int max)) in - let (compose_vars,new_sigma) = (compose ((max+1),subst) (v,(ft @ [v_new]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in - if (bool=false) then - raise Not_unifiable - else - let new_ordering = - build_orderingJ (v::compose_vars) (ft @ [v_new]) ordering atom_rel in - tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma new_ordering - - in - let apply_r10 fs ft rt rest_eq sigma = -(* print_endline "r10"; *) - let x = List.hd rt in - tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma ordering - - in - if r_1 fs ft rt then - apply_r1 fs ft rt rest_eq sigma - else if r_2 fs ft rt then - apply_r2 fs ft rt rest_eq sigma - else if r_3 fs ft rt then - apply_r3 fs ft rt rest_eq sigma - else if r_4 fs ft rt then - apply_r4 fs ft rt rest_eq sigma - else if r_5 fs ft rt then - apply_r5 fs ft rt rest_eq sigma - else if r_6 fs ft rt then - (try - apply_r6 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *) - ) - else -(* r10 could be represented only once if we would try it before r7.*) -(* but looking at the transformation rules, r10 should be tried at last in any case *) - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable r6 was *) - ) - else if r_7 fs ft rt then (* not r6 and r7 possible if z <> [] *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r7 was *) - ) - else if r_8 fs ft rt then - (try - apply_r8 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - else if r_9 fs ft rt then - (try - apply_r9 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - - - else - if r_10 fs ft rt then (* not ri, i<10, and r10 possible if for instance *) - (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *) - apply_r10 fs ft rt rest_eq sigma - else (* NO rule applicable *) - raise Not_unifiable - in - match eqlist with - [] -> - init_sigma,orderingQ - | f::rest_eq -> - begin -(* Format.open_box 0; - print_equations [f]; - Format.print_flush (); -*) - let (atomnames,(fs,ft)) = f in - tunify atomnames fs [] ft rest_eq init_sigma orderingQ - end - -let rec test_apply_eq atomnames eqs eqt subst = - match subst with - [] -> (eqs,eqt) - | (f,flist)::r -> - let (first_appl_eqs,first_appl_eqt) = - if List.mem f atomnames then - (eqs,eqt) - else - (apply_element eqs eqt (f,flist)) - in - test_apply_eq atomnames first_appl_eqs first_appl_eqt r - -let rec test_apply_eqsubst eqlist subst = - match eqlist with - [] -> [] - | f::r -> - let (atomnames,(eqs,eqt)) = f in - let applied_element = test_apply_eq atomnames eqs eqt subst in - (atomnames,applied_element)::(test_apply_eqsubst r subst) - -let ttest us ut ns nt eqlist orderingQ atom_rel = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *) - (* to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element eqlist then - eqlist - else - new_element::eqlist - in - let (sigma,_) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in - let (n,subst) = sigma in - let test_apply = test_apply_eqsubst full_eqlist subst in - begin - print_endline ""; - print_endline "Final equations:"; - print_equations full_eqlist; - print_endline ""; - print_endline "Final substitution:"; - print_tunify sigma; - print_endline ""; - print_endline "Applied equations:"; - print_equations test_apply - end - -let do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel qmax = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element equations then - equations @ fo_eqlist - else - (new_element::equations) @ fo_eqlist - in - try -(* print_equations full_eqlist; *) -(* max-1 new variables have been used for the domain equations *) - let (new_sigma,new_ordering) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in -(* sigmaQ will not be returned in eqlist *) - (new_sigma,(qmax,full_eqlist),new_ordering) - with Not_unifiable -> - raise Failed (* new connection please *) - -let rec one_equation gprefix dlist delta_0_prefixes n = - match dlist with - [] -> ([],n) - | f::r -> - let fprefix = List.assoc f delta_0_prefixes in - let (sf1,sg) = shorten fprefix gprefix - and v_new = ("vnewq"^(string_of_int n)) in - let fnew = sf1 @ [v_new] in - let (rest_equations,new_n) = one_equation gprefix r delta_0_prefixes (n+1) in - (([],(fnew,sg))::rest_equations),new_n - -let rec make_domain_equations fo_pairs (gamma_0_prefixes,delta_0_prefixes) n = - match fo_pairs with - [] -> ([],n) - | (g,dlist)::r -> - let gprefix = List.assoc g gamma_0_prefixes in - let (gequations,max) = one_equation gprefix dlist delta_0_prefixes n in - let (rest_equations,new_max) = - make_domain_equations r (gamma_0_prefixes,delta_0_prefixes) max in - (gequations @ rest_equations),new_max - -(* type of one unifier: int * ((string * string list) list) *) -(* global failure: (0,[]) *) - -let stringunify ext_atom try_one eqlist fo_pairs logic orderingQ atom_rel qprefixes = - if logic = "C" then - ((0,[]),(0,[]),orderingQ) - else - let (qmax,equations) = eqlist - and us = ext_atom.aprefix - and ut = try_one.aprefix - and ns = ext_atom.aname - and nt = try_one.aname in - if qprefixes = ([],[]) then (* prop case *) - begin -(* print_endline "This is the prop case"; *) - let (new_sigma,new_eqlist) = Jtunify.do_stringunify us ut ns nt equations - (* prop unification only *) - in - (new_sigma,new_eqlist,[]) (* assume the empty reduction ordering during proof search *) - end - else - begin -(* print_endline "This is the FO case"; *) -(* fo_eqlist encodes the domain condition on J quantifier substitutions *) -(* Again, always computed for the whole substitution sigmaQ *) - let (fo_eqlist,new_max) = make_domain_equations fo_pairs qprefixes qmax in - begin -(* Format.open_box 0; - print_string "domain equations in"; - print_equations fo_eqlist; - print_string "domain equations out"; - Format.print_flush (); -*) - do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel new_max - end - end - -(**************************************** add multiplicity *********************************) - -let rec subst_replace subst_list t = - match subst_list with - [] -> t - | (old_t,new_t)::r -> - let inter_term = var_subst t old_t "dummy" in - let new_term = subst1 inter_term "dummy" new_t in - subst_replace r new_term - -let rename_pos x m = - let pref = String.get x 0 in - (Char.escaped pref)^(string_of_int m) - -let update_position position m replace_n subst_list mult = - let ({name=x; address=y; op=z; pol=p; pt=a; st=b; label=t}) = position in - let nx = rename_pos x m in - let nsubst_list = - if b=Gamma_0 then - let vx = mk_var_term (x^"_jprover") - and vnx = mk_var_term (nx^"_jprover") in - (vx,vnx)::subst_list - else - if b=Delta_0 then - let sx = mk_string_term jprover_op x - and snx = mk_string_term jprover_op nx in - (sx,snx)::subst_list - else - subst_list - in - let nt = subst_replace nsubst_list t in - let add_array = Array.of_list y in - let _ = (add_array.(replace_n) <- mult) in - let new_add = Array.to_list add_array in - ({name=nx; address=new_add; op=z; pol=p; pt=a; st=b; label=nt},m,nsubst_list) - -let rec append_orderings list_of_lists = - match list_of_lists with - [] -> - [] - | f::r -> - f @ (append_orderings r) - -let rec union_orderings first_orderings = - match first_orderings with - [] -> - StringSet.empty - | (pos,fset)::r -> - StringSet.union (StringSet.add pos fset) (union_orderings r) - -let rec select_orderings add_orderings = - match add_orderings with - [] -> [] - | f::r -> - (List.hd f)::select_orderings r - -let combine_ordering_list add_orderings pos_name = - let first_orderings = select_orderings add_orderings in - let pos_succs = union_orderings first_orderings in - let rest_orderings = append_orderings add_orderings in - (pos_name,pos_succs)::rest_orderings - -let rec copy_and_rename_tree last_tree replace_n pos_n mult subst_list = - - let rec rename_subtrees tree_list nposition s_pos_n nsubst_list = - match tree_list with - [] -> ([||],[],s_pos_n) - | f::r -> - let (f_subtree,f_ordering,f_pos_n) = - copy_and_rename_tree f replace_n s_pos_n mult nsubst_list in - let (r_subtrees,r_ordering_list,r_pos_n) = rename_subtrees r nposition f_pos_n nsubst_list in - ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n) - - in - match last_tree with - Empty -> raise (Invalid_argument "Jprover: copy tree") - | NodeAt(position) -> (* can never be a Gamma_0 position -> no replacements *) - let (nposition,npos_n,_) = update_position position (pos_n+1) replace_n subst_list mult in - ((NodeAt(nposition)),[(nposition.name,StringSet.empty)],npos_n) - | NodeA(position, suctrees) -> - let (nposition,npos_n,nsubst_list) = update_position position (pos_n+1) replace_n subst_list mult in - let (new_suctrees, new_ordering_list, new_pos_n) = - rename_subtrees (Array.to_list suctrees) nposition npos_n nsubst_list in - let new_ordering = combine_ordering_list new_ordering_list (nposition.name) in - ((NodeA(nposition,new_suctrees)),new_ordering,new_pos_n) - -(* we construct for each pos a list orderings representing and correspondning to the array of succtrees *) - -let rec add_multiplicity ftree pos_n mult logic = - let rec parse_subtrees tree_list s_pos_n = - match tree_list with - [] -> ([||],[],s_pos_n) - | f::r -> - let (f_subtree,f_ordering,f_pos_n) = add_multiplicity f s_pos_n mult logic in - let (r_subtrees,r_ordering_list,r_pos_n) = parse_subtrees r f_pos_n in - ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n) - - in - match ftree with - Empty -> raise (Invalid_argument "Jprover: add mult") - | NodeAt(pos) -> (ftree,[(pos.name,StringSet.empty)],pos_n) - | NodeA(pos,suctrees) -> - let (new_suctrees, new_ordering_list, new_pos_n) = parse_subtrees (Array.to_list suctrees) pos_n in - if (((pos.pt = Phi) & (((pos.op <> At) & (logic="J")) or ((pos.op = All) & (logic = "C")))) - (* no explicit atom-instances *) - or ((pos.pt = Gamma) & (pos.st <> Phi_0))) then (* universal quantifiers are copied *) - (* at their Phi positions *) - let replace_n = (List.length pos.address) (* points to the following argument in the array_of_address *) - and last = (Array.length new_suctrees) - 1 in (* array first element has index 0 *) - let last_tree = new_suctrees.(last) in - let (add_tree,add_ordering,final_pos_n) = - copy_and_rename_tree last_tree replace_n new_pos_n mult [] in - let final_suctrees = Array.append new_suctrees [|add_tree|] - and add_orderings = List.append new_ordering_list [add_ordering] in - let final_ordering = combine_ordering_list add_orderings (pos.name) in - ((NodeA(pos,final_suctrees)),final_ordering,final_pos_n) - else - let final_ordering = combine_ordering_list new_ordering_list (pos.name) in - ((NodeA(pos,new_suctrees)),final_ordering,new_pos_n) - - -(************** Path checker ****************************************************) - -let rec get_sets atom atom_sets = - match atom_sets with - [] -> raise (Invalid_argument "Jprover bug: atom not found") - | f::r -> - let (a,b,c) = f in - if atom = a then f - else - get_sets atom r - -let rec get_connections a alpha tabulist = - match alpha with - [] -> [] - | f::r -> - if (a.apredicate = f.apredicate) & (a.apol <> f.apol) & (not (List.mem f tabulist)) then - (a,f)::(get_connections a r tabulist) - else - (get_connections a r tabulist) - -let rec connections atom_rel tabulist = - match atom_rel with - [] -> [] - | f::r -> - let (a,alpha,beta) = f in - (get_connections a alpha tabulist) @ (connections r (a::tabulist)) - -let check_alpha_relation atom set atom_sets = - let (a,alpha,beta) = get_sets atom atom_sets in - AtomSet.subset set alpha - -let rec extset atom_sets path closed = - match atom_sets with - [] -> AtomSet.empty - | f::r -> - let (at,alpha,beta) = f in - if (AtomSet.subset path alpha) & (AtomSet.subset closed beta) then - AtomSet.add at (extset r path closed) - else - (extset r path closed) - -let rec check_ext_list ext_list fail_set atom_sets = (* fail_set consists of one atom only *) - match ext_list with - [] -> AtomSet.empty - | f::r -> - if (check_alpha_relation f fail_set atom_sets) then - AtomSet.add f (check_ext_list r fail_set atom_sets) - else - (check_ext_list r fail_set atom_sets) - -let fail_ext_set ext_atom ext_set atom_sets = - let ext_list = AtomSet.elements ext_set - and fail_set = AtomSet.add ext_atom AtomSet.empty in - check_ext_list ext_list fail_set atom_sets - -let rec ext_partners con path ext_atom (reduction_partners,extension_partners) atom_sets = - match con with - [] -> - (reduction_partners,extension_partners) - | f::r -> - let (a,b) = f in - if List.mem ext_atom [a;b] then - let ext_partner = - if ext_atom = a then b else a - in - let (new_red_partners,new_ext_partners) = -(* force reduction steps first *) - if (AtomSet.mem ext_partner path) then - ((AtomSet.add ext_partner reduction_partners),extension_partners) - else - if (check_alpha_relation ext_partner path atom_sets) then - (reduction_partners,(AtomSet.add ext_partner extension_partners)) - else - (reduction_partners,extension_partners) - in - ext_partners r path ext_atom (new_red_partners,new_ext_partners) atom_sets - else - ext_partners r path ext_atom (reduction_partners,extension_partners) atom_sets - -exception Failed_connections - -let path_checker atom_rel atom_sets qprefixes init_ordering logic = - - let con = connections atom_rel [] in - let rec provable path closed (orderingQ,reduction_ordering) eqlist (sigmaQ,sigmaJ) = - - let rec check_connections (reduction_partners,extension_partners) ext_atom = - let try_one = - if reduction_partners = AtomSet.empty then - if extension_partners = AtomSet.empty then - raise Failed_connections - else - AtomSet.choose extension_partners - else - (* force reduction steps always first!! *) - AtomSet.choose reduction_partners - in -(* print_endline ("connection partner "^(try_one.aname)); *) -(* print_endline ("partner path "^(print_set path)); -*) - (try - let (new_sigmaQ,new_ordering_elements) = jqunify (ext_atom.alabel) (try_one.alabel) sigmaQ in -(* build the orderingQ incrementally from the new added substitution tau of new_sigmaQ *) - let (relate_pairs,new_orderingQ) = build_orderingQ new_ordering_elements orderingQ in -(* we make in incremental reflexivity test during the string unification *) - let (new_sigmaJ,new_eqlist,new_red_ordering) = -(* new_red_ordering = [] in propositional case *) - stringunify ext_atom try_one eqlist relate_pairs logic new_orderingQ atom_rel qprefixes - in -(* print_endline ("make reduction ordering "^((string_of_int (List.length new_ordering)))); *) - let new_closed = AtomSet.add ext_atom closed in - let ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),subproof) = - if AtomSet.mem try_one path then - provable path new_closed (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ) - (* always use old first-order ordering for recursion *) - else - let new_path = AtomSet.add ext_atom path - and extension = AtomSet.add try_one AtomSet.empty in - let ((norderingQ,nredordering),neqlist,(nsigmaQ,nsigmaJ),p1) = - provable new_path extension (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ) in - let ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),p2) = - provable path new_closed (norderingQ,nredordering) neqlist (nsigmaQ,nsigmaJ) in - ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),(p1 @ p2)) - (* first the extension subgoals = depth first; then other subgoals in same clause *) - in - ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),(((ext_atom.aname),(try_one.aname))::subproof)) - with Failed -> -(* print_endline ("new connection for "^(ext_atom.aname)); *) -(* print_endline ("Failed"); *) - check_connections ((AtomSet.remove try_one reduction_partners), - (AtomSet.remove try_one extension_partners) - ) ext_atom - ) - - in - let rec check_extension extset = - if extset = AtomSet.empty then - raise Failed (* go directly to a new entry connection *) - else - let select_one = AtomSet.choose extset in -(* print_endline ("extension literal "^(select_one.aname)); *) -(* print_endline ("extension path "^(print_set path));*) - let (reduction_partners,extension_partners) = - ext_partners con path select_one (AtomSet.empty,AtomSet.empty) atom_sets in - (try - check_connections (reduction_partners,extension_partners) select_one - with Failed_connections -> -(* print_endline ("no connections for subgoal "^(select_one.aname)); *) -(* print_endline ("Failed_connections"); *) - let fail_ext_set = fail_ext_set select_one extset atom_sets in - check_extension fail_ext_set - ) - - in - let extset = extset atom_sets path closed in - if extset = AtomSet.empty then - ((orderingQ,reduction_ordering),eqlist,(sigmaQ,sigmaJ),[]) - else - check_extension extset - in - if qprefixes = ([],[]) then - begin -(* print_endline "!!!!!!!!!!! prop prover !!!!!!!!!!!!!!!!!!"; *) -(* in the propositional case, the reduction ordering will be computed AFTER proof search *) - let (_,eqlist,(_,(n,substJ)),ext_proof) = - provable AtomSet.empty AtomSet.empty ([],[]) (1,[]) ([],(1,[])) in - let orderingJ = build_orderingJ_list substJ init_ordering atom_rel in - ((init_ordering,orderingJ),eqlist,([],(n,substJ)),ext_proof) - end - else - provable AtomSet.empty AtomSet.empty (init_ordering,[]) (1,[]) ([],(1,[])) - -(*************************** prepare and init prover *******************************************************) - -let rec list_to_set list = - match list with - [] -> AtomSet.empty - | f::r -> - let rest_set = list_to_set r in - AtomSet.add f rest_set - -let rec make_atom_sets atom_rel = - match atom_rel with - [] -> [] - | f::r -> - let (a,alpha,beta) = f in - (a,(list_to_set alpha),(list_to_set beta))::(make_atom_sets r) - -let rec predecessor address_1 address_2 ftree = - match ftree with - Empty -> PNull (* should not occur since every pair of atoms have a common predecessor *) - | NodeAt(position) -> PNull (* should not occur as above *) - | NodeA(position,suctrees) -> - match address_1,address_2 with - [],_ -> raise (Invalid_argument "Jprover: predecessors left") - | _,[] -> raise (Invalid_argument "Jprover: predecessors right") - | (f1::r1),(f2::r2) -> - if f1 = f2 then - predecessor r1 r2 (suctrees.(f1-1)) - else - position.pt - -let rec compute_sets element ftree alist = - match alist with - [] -> [],[] - | first::rest -> - if first = element then - compute_sets element ftree rest (* element is neithes alpha- nor beta-related to itself*) - else - let (alpha_rest,beta_rest) = compute_sets element ftree rest in - if predecessor (element.aaddress) (first.aaddress) ftree = Beta then - (alpha_rest,(first::beta_rest)) - else - ((first::alpha_rest),beta_rest) - -let rec compute_atomlist_relations worklist ftree alist = (* last version of alist for total comparison *) - let rec compute_atom_relations element ftree alist = - let alpha_set,beta_set = compute_sets element ftree alist in - (element,alpha_set,beta_set) - in - match worklist with - [] -> [] - | first::rest -> - let first_relations = compute_atom_relations first ftree alist in - first_relations::(compute_atomlist_relations rest ftree alist) - -let atom_record position prefix = - let aname = (position.name) in - let aprefix = (List.append prefix [aname]) in (* atom position is last element in prefix *) - let aop = (dest_term position.label).term_op in - ({aname=aname; aaddress=(position.address); aprefix=aprefix; apredicate=aop; - apol=(position.pol); ast=(position.st); alabel=(position.label)}) - -let rec select_atoms_treelist treelist prefix = - let rec select_atoms ftree prefix = - match ftree with - Empty -> [],[],[] - | NodeAt(position) -> - [(atom_record position prefix)],[],[] - | NodeA(position,suctrees) -> - let treelist = Array.to_list suctrees in - let new_prefix = - let prefix_element = - if List.mem (position.st) [Psi_0;Phi_0] then - [(position.name)] - else - [] - in - (List.append prefix prefix_element) - in - let (gamma_0_element,delta_0_element) = - if position.st = Gamma_0 then - begin -(* Format.open_box 0; - print_endline "gamma_0 prefixes "; - print_string (position.name^" :"); - print_stringlist prefix; - print_endline " "; - Format.force_newline (); - Format.print_flush (); -*) - [(position.name,prefix)],[] - end - else - if position.st = Delta_0 then - begin -(* Format.open_box 0; - print_endline "delta_0 prefixes "; - print_string (position.name^" :"); - print_stringlist prefix; - print_endline " "; - Format.force_newline (); - Format.print_flush (); -*) - [],[(position.name,prefix)] - end - else - [],[] - in - let (rest_alist,rest_gamma_0_prefixes,rest_delta_0_prefixes) = - select_atoms_treelist treelist new_prefix in - (rest_alist,(rest_gamma_0_prefixes @ gamma_0_element), - (rest_delta_0_prefixes @ delta_0_element)) - - in - match treelist with - [] -> [],[],[] - | first::rest -> - let (first_alist,first_gprefixes,first_dprefixes) = select_atoms first prefix - and (rest_alist,rest_gprefixes,rest_dprefixes) = select_atoms_treelist rest prefix in - ((first_alist @ rest_alist),(first_gprefixes @ rest_gprefixes), - (first_dprefixes @ rest_dprefixes)) - -let prepare_prover ftree = - let alist,gamma_0_prefixes,delta_0_prefixes = select_atoms_treelist [ftree] [] in - let atom_rel = compute_atomlist_relations alist ftree alist in - (atom_rel,(gamma_0_prefixes,delta_0_prefixes)) - -(* ************************ Build intial formula tree and relations *********************************** *) -(* Building a formula tree and the tree ordering from the input formula, i.e. OCaml term *) - -let make_position_name stype pos_n = - let prefix = - if List.mem stype [Phi_0;Gamma_0] - then "v" - else - if List.mem stype [Psi_0;Delta_0] - then "c" - else - "a" - in - prefix^(string_of_int pos_n) - -let dual_pol pol = - if pol = O then I else O - -let check_subst_term (variable,old_term) pos_name stype = - if (List.mem stype [Gamma_0;Delta_0]) then - let new_variable = - if stype = Gamma_0 then (mk_var_term (pos_name^"_jprover")) - else - (mk_string_term jprover_op pos_name) - in - (subst1 old_term variable new_variable) (* replace variable (non-empty) in t by pos_name *) - (* pos_name is either a variable term or a constant, f.i. a string term *) - (* !!! check unification module how handling eingenvariables as constants !!! *) - else - old_term - -let rec build_ftree (variable,old_term) pol stype address pos_n = - let pos_name = make_position_name stype pos_n in - let term = check_subst_term (variable,old_term) pos_name stype in - if JLogic.is_and_term term then - let s,t = JLogic.dest_and term in - let ptype,stype_1,stype_2 = - if pol = O - then Beta,Beta_1,Beta_2 - else - Alpha,Alpha_1,Alpha_2 - in - let position = {name=pos_name; address=address; op=And; pol=pol; pt=ptype; st=stype; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in - let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2]) - (posn_left+1) in - let (succ_left,whole_left) = List.hd ordering_left - and (succ_right,whole_right) = List.hd ordering_right in - let pos_succs = - (StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right))) - in - (NodeA(position,[|subtree_left;subtree_right|]), - ((position.name,pos_succs)::(ordering_left @ ordering_right)), - posn_right - ) - else - if JLogic.is_or_term term then - let s,t = JLogic.dest_or term in - let ptype,stype_1,stype_2 = - if pol = O - then Alpha,Alpha_1,Alpha_2 - else - Beta,Beta_1,Beta_2 - in - let position = {name=pos_name; address=address; op=Or; pol=pol; pt=ptype; st=stype; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in - let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2]) - (posn_left+1) in - let (succ_left,whole_left) = List.hd ordering_left - and (succ_right,whole_right) = List.hd ordering_right in - let pos_succs = - StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in - (NodeA(position,[|subtree_left;subtree_right|]), - ((position.name),pos_succs) :: (ordering_left @ ordering_right), - posn_right - ) - else - if JLogic.is_implies_term term then - let s,t = JLogic.dest_implies term in - let ptype_0,stype_0,ptype,stype_1,stype_2 = - if pol = O - then Psi,Psi_0,Alpha,Alpha_1,Alpha_2 - else - Phi,Phi_0,Beta,Beta_1,Beta_2 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=Imp; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=Imp; pol=pol; pt=ptype; st=stype_0; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1]) - (pos_n+2) in - let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[1;2]) - (posn_left+1) in - let (succ_left,whole_left) = List.hd ordering_left - and (succ_right,whole_right) = List.hd ordering_right in - let pos_succs = - StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in - let pos_ordering = (position.name,pos_succs) :: (ordering_left @ ordering_right) in - (NodeA(sposition,[|NodeA(position,[|subtree_left;subtree_right|])|]), - ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), - posn_right - ) - else - if JLogic.is_not_term term then - let s = JLogic.dest_not term in - let ptype_0,stype_0,ptype,stype_1= - if pol = O - then Psi,Psi_0,Alpha,Alpha_1 - else - Phi,Phi_0,Alpha,Alpha_1 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=Neg; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=Neg; pol=pol; pt=ptype; st=stype_0; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1]) - (pos_n+2) in - let (succ_left,whole_left) = List.hd ordering_left in - let pos_succs = - StringSet.add succ_left whole_left in - let pos_ordering = (position.name,pos_succs) :: ordering_left in - (NodeA(sposition,[|NodeA(position,[| subtree_left|])|]), - ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), - posn_left - ) - else - if JLogic.is_exists_term term then - let v,s,t = JLogic.dest_exists term in (* s is type of v and will be supressed here *) - let ptype,stype_1 = - if pol = O - then Gamma,Gamma_0 - else - Delta,Delta_0 - in - let position = {name=pos_name; address=address; op=Ex; pol=pol; pt=ptype; st=stype; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1]) (pos_n+1) in - let (succ_left,whole_left) = List.hd ordering_left in - let pos_succs = - StringSet.add succ_left whole_left in - (NodeA(position,[|subtree_left|]), - ((position.name,pos_succs) :: ordering_left), - posn_left - ) - else - if JLogic.is_all_term term then - let v,s,t = JLogic.dest_all term in - (* s is type of v and will be supressed here *) - let ptype_0,stype_0,ptype,stype_1= - if pol = O - then Psi,Psi_0,Delta,Delta_0 - else - Phi,Phi_0,Gamma,Gamma_0 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=All; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=All; pol=pol; pt=ptype; st=stype_0; label=term} in - let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1;1]) - (pos_n+2) in - let (succ_left,whole_left) = List.hd ordering_left in - let pos_succs = - StringSet.add succ_left whole_left in - let pos_ordering = (position.name,pos_succs) :: ordering_left in - (NodeA(sposition,[|NodeA(position,[|subtree_left|])|]), - ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), - posn_left - ) - else (* finally, term is atomic *) - let ptype_0,stype_0 = - if pol = O - then Psi,Psi_0 - else - Phi,Phi_0 - in - let pos2_name = make_position_name stype_0 (pos_n+1) in - let sposition = {name=pos_name; address=address; op=At; pol=pol; pt=ptype_0; st=stype; label=term} - and position = {name=pos2_name; address=address@[1]; op=At; pol=pol; pt=PNull; st=stype_0; label=term} in - (NodeA(sposition,[|NodeAt(position)|]), - [(sposition.name,(StringSet.add position.name StringSet.empty));(position.name,StringSet.empty)], - pos_n+1 - ) - -let rec construct_ftree termlist treelist orderinglist pos_n goal = - match termlist with - [] -> - let new_root = {name="w"; address=[]; op=Null; pol=O; pt=Psi; st=PNull_0; label=goal} - and treearray = Array.of_list treelist in - NodeA(new_root,treearray),(("w",(union_orderings orderinglist))::orderinglist),pos_n - | ft::rest_terms -> - let next_address = [((List.length treelist)+1)] - and next_pol,next_goal = - if rest_terms = [] then - O,ft (* construct tree for the conclusion *) - else - I,goal - in - let new_tree,new_ordering,new_pos_n = - build_ftree ("",ft) next_pol Alpha_1 next_address (pos_n+1) in - construct_ftree rest_terms (treelist @ [new_tree]) - (orderinglist @ new_ordering) new_pos_n next_goal - -(*************************** Main LOOP ************************************) -let unprovable = RefineError ("Jprover", StringError "formula is not provable") -let mult_limit_exn = RefineError ("Jprover", StringError "multiplicity limit reached") -let coq_exn = RefineError ("Jprover", StringError "interface for coq: error on ") - -let init_prover ftree = - let atom_relation,qprefixes = prepare_prover ftree in -(* print_atom_info atom_relation; *) (* apple *) - let atom_sets = make_atom_sets atom_relation in - (atom_relation,atom_sets,qprefixes) - - -let rec try_multiplicity mult_limit ftree ordering pos_n mult logic = - try - let (atom_relation,atom_sets,qprefixes) = init_prover ftree in - let ((orderingQ,red_ordering),eqlist,unifier,ext_proof) = - path_checker atom_relation atom_sets qprefixes ordering logic in - (ftree,red_ordering,eqlist,unifier,ext_proof) (* orderingQ is not needed as return value *) - with Failed -> - match mult_limit with - Some m when m == mult -> - raise mult_limit_exn - | _ -> - let new_mult = mult+1 in - begin - Pp.msgnl (Pp.(++) (Pp.str "Multiplicity Fail: Trying new multiplicity ") - (Pp.int new_mult)); -(* - Format.open_box 0; - Format.force_newline (); - Format.print_string "Multiplicity Fail: "; - Format.print_string ("Try new multiplicity "^(string_of_int new_mult)); - Format.force_newline (); - Format.print_flush (); -*) - let (new_ftree,new_ordering,new_pos_n) = - add_multiplicity ftree pos_n new_mult logic in - if (new_ftree = ftree) then - raise unprovable - else -(* print_formula_info new_ftree new_ordering new_pos_n; *) (* apple *) - try_multiplicity mult_limit new_ftree new_ordering new_pos_n new_mult logic - end - -let prove mult_limit termlist logic = - let (ftree,ordering,pos_n) = construct_ftree termlist [] [] 0 (mk_var_term "dummy") in -(* pos_n = number of positions without new root "w" *) -(* print_formula_info ftree ordering pos_n; *) (* apple *) - try_multiplicity mult_limit ftree ordering pos_n 1 logic - -(********** first-order type theory interface *******************) - -let rec renam_free_vars termlist = - match termlist - with [] -> [],[] - | f::r -> - let var_names = free_vars_list f in - let string_terms = - List.map (fun x -> (mk_string_term free_var_op x)) var_names - in - let mapping = List.combine var_names string_terms - and new_f = subst f var_names string_terms in - let (rest_mapping,rest_renamed) = renam_free_vars r in - let unique_mapping = remove_dups_list (mapping @ rest_mapping) in - (unique_mapping,(new_f::rest_renamed)) - -let rec apply_var_subst term var_subst_list = - match var_subst_list with - [] -> term - | (v,t)::r -> - let next_term = var_subst term t v in - apply_var_subst next_term r - -let rec make_equal_list n list_object = - if n = 0 then - [] - else - list_object::(make_equal_list (n-1) list_object) - -let rec create_output rule_list input_map = - match rule_list with - [] -> JLogic.empty_inf - | f::r -> - let (pos,(rule,term1,term2)) = f in - let delta1_names = collect_delta_terms [term1] - and delta2_names = collect_delta_terms [term2] in - let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in - let delta_terms = - List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in - let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in - let delta_map = List.combine delta_vars delta_terms in - let var_mapping = (input_map @ delta_map) in - let frees1 = free_vars_list term1 - and frees2 = free_vars_list term2 in - let unique_object = mk_var_term "v0_jprover" in - let unique_list1 = make_equal_list (List.length frees1) unique_object - and unique_list2 = make_equal_list (List.length frees2) unique_object - in - let next_term1 = subst term1 frees1 unique_list1 - and next_term2 = subst term2 frees2 unique_list2 in - let new_term1 = apply_var_subst next_term1 var_mapping - and new_term2 = apply_var_subst next_term2 var_mapping - and (a,b) = pos - in - -(* kick away the first argument, the position *) - (JLogic.append_inf (create_output r input_map) (b,new_term1) (a,new_term2) rule) - -let rec make_test_interface rule_list input_map = - match rule_list with - [] -> [] - | f::r -> - let (pos,(rule,term1,term2)) = f in - let delta1_names = collect_delta_terms [term1] - and delta2_names = collect_delta_terms [term2] in - let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in - let delta_terms = - List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in - let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in - let delta_map = List.combine delta_vars delta_terms in - let var_mapping = (input_map @ delta_map) in - let frees1 = free_vars_list term1 - and frees2 = free_vars_list term2 in - let unique_object = mk_var_term "v0_jprover" in - let unique_list1 = make_equal_list (List.length frees1) unique_object - and unique_list2 = make_equal_list (List.length frees2) unique_object - in - begin -(* - print_endline ""; - print_endline ""; - print_stringlist frees1; - print_endline ""; - print_stringlist frees2; - print_endline ""; - print_endline ""; -*) - let next_term1 = subst term1 frees1 unique_list1 - and next_term2 = subst term2 frees2 unique_list2 in - let new_term1 = apply_var_subst next_term1 var_mapping - and new_term2 = apply_var_subst next_term2 var_mapping - in - (pos,(rule,new_term1,new_term2))::(make_test_interface r input_map) - end - -(**************************************************************) - -let decomp_pos pos = - let {name=n; address=a; label=l} = pos in - (n,(a,l)) - -let rec build_formula_id ftree = - let rec build_fid_list = function - [] -> [] - | t::rest -> (build_formula_id t)@(build_fid_list rest) - in - match ftree with - Empty -> [] - | NodeAt(position) -> - [decomp_pos position] - | NodeA(position,subtrees) -> - let tree_list = Array.to_list subtrees in - (decomp_pos position)::(build_fid_list tree_list) - -let rec encode1 = function (* normal *) - [] -> "" - | i::r -> "_"^(string_of_int i)^(encode1 r) - -let rec encode2 = function (* move up *) - [i] -> "" - | i::r -> "_"^(string_of_int i)^(encode2 r) - | _ -> raise coq_exn - -let rec encode3 = function (* move down *) - [] -> "_1" - | i::r -> "_"^(string_of_int i)^(encode3 r) - -let lookup_coq str map = - try - let (il,t) = List.assoc str map in - il - with Not_found -> raise coq_exn - -let create_coq_input inf map = - let rec rec_coq_part inf = - match inf with - [] -> [] - | (rule, (s1, t1), ((s2, t2) as k))::r -> - begin - match rule with - Andl | Andr | Orl | Orr1 | Orr2 -> - (rule, (encode1 (lookup_coq s1 map), t1), k)::(rec_coq_part r) - | Impr | Impl | Negr | Negl | Ax -> - (rule, (encode2 (lookup_coq s1 map), t1), k)::(rec_coq_part r) - | Exr -> - (rule, (encode1 (lookup_coq s1 map), t1), - (encode1 (lookup_coq s2 map), t2))::(rec_coq_part r) - | Exl -> - (rule, (encode1 (lookup_coq s1 map), t1), - (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r) - | Allr | Alll -> - (rule, (encode2 (lookup_coq s1 map), t1), - (* (s2, t2))::(rec_coq_part r) *) - (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r) - | _ -> raise coq_exn - end - in - rec_coq_part inf - -let gen_prover mult_limit logic calculus hyps concls = - let (input_map,renamed_termlist) = renam_free_vars (hyps @ concls) in - let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in - let sequent_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in - let idl = build_formula_id ftree in -(* print_ftree ftree; apple *) - (* transform types and rename constants *) - (* we can transform the eigenvariables AFTER proof reconstruction since *) - (* new delta_0 constants may have been constructed during rule permutation *) - (* from the LJmc to the LJ proof *) - create_coq_input (create_output sequent_proof input_map) idl - -let prover mult_limit hyps concl = gen_prover mult_limit "J" "LJ" hyps [concl] - -(************* test with propositional proof reconstruction ************) - -let rec count_axioms seq_list = - match seq_list with - [] -> 0 - | f::r -> - let (rule,_,_) = f in - if rule = Ax then - 1 + count_axioms r - else - count_axioms r - -let do_prove mult_limit termlist logic calculus = - try begin - let (input_map,renamed_termlist) = renam_free_vars termlist in - let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in - Format.open_box 0; - Format.force_newline (); - Format.force_newline (); - Format.print_string "Extension proof ready"; - Format.force_newline (); - Format.force_newline (); - Format.print_string ("Length of Extension proof: "^((string_of_int (List.length ext_proof)))^ - " Axioms"); - Format.force_newline (); - Format.force_newline (); - print_endline "Extension proof:"; - Format.open_box 0; - print_pairlist ext_proof; (* print list of type (string * string) list *) - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.print_flush (); - Format.print_flush (); - Format.open_box 0; - print_ordering red_ordering; - Format.print_flush (); - Format.open_box 0; - Format.force_newline (); -(* ----------------------------------------------- *) - Format.open_box 0; - print_tunify sigmaJ; - Format.print_flush (); - print_endline ""; - print_endline ""; - print_sigmaQ sigmaQ; - print_endline ""; - print_endline ""; - Format.open_box 0; - let (qmax,equations) = eqlist in - print_endline ("number of quantifier domains : "^(string_of_int (qmax-1))); - print_endline ""; - print_equations equations; - Format.print_flush (); - print_endline ""; - print_endline ""; - print_endline ("Length of equations : "^((string_of_int (List.length equations)))); - print_endline ""; - print_endline ""; -(* --------------------------------------------------------- *) - Format.print_string "Break ... "; - print_endline ""; - print_endline ""; - Format.print_flush (); - let reconstr_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in - let sequent_proof = make_test_interface reconstr_proof input_map in - Format.open_box 0; - Format.force_newline (); - Format.force_newline (); - Format.print_string "Sequent proof ready"; - Format.force_newline (); - Format.force_newline (); - Format.print_flush (); - let (ptree,count_ax) = bproof sequent_proof in - Format.open_box 0; - Format.print_string ("Length of sequent proof: "^((string_of_int count_ax))^" Axioms"); - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.force_newline (); - Format.print_flush (); - tt ptree; - Format.print_flush (); - print_endline ""; - print_endline "" - end with exn -> begin - print_endline "Jprover got an exception:"; - print_endline (Printexc.to_string exn) - end - -let test concl logic calculus = (* calculus should be LJmc or LJ for J, and LK for C *) - do_prove None [concl] logic calculus - -(* for sequents *) - -let seqtest list_term logic calculus = - let bterms = (dest_term list_term).term_terms in - let termlist = collect_subterms bterms in - do_prove None termlist logic calculus - -(*****************************************************************) - -end (* of struct *) diff --git a/contrib/jprover/jall.mli b/contrib/jprover/jall.mli deleted file mode 100644 index 1811fe59..00000000 --- a/contrib/jprover/jall.mli +++ /dev/null @@ -1,339 +0,0 @@ -(* JProver provides an efficient refiner for first-order classical - and first-order intuitionistic logic. It consists of two main parts: - a proof search procedure and a proof reconstruction procedure. - - - Proof Search - ============ - - The proof search process is based on a matrix-based (connection-based) - proof procedure, i.e.~a non-normalform extension procedure. - Besides the well-known quantifier substitution (Martelli Montanari), - a special string unifiation procedure is used in order to - efficiently compute intuitionistic rule non-permutabilities. - - - Proof Reconstruction - ==================== - - The proof reconstruction process converts machine-generated matrix proofs - into cut-free Gentzen-style sequent proofs. For classcal logic "C", - Gentzen's sequent calculus "LK" is used as target calculus. - For intuitionistic logic "J", either Gentzen's single-conclusioned sequent - calculus "LJ" or Fitting's multiply-conclusioned sequent calculus "LJmc" - can be used. All sequent claculi are implemented in a set-based formulation - in order to avoid structural rules. - - The proof reconstruction procedure combines three main procedures, depending - on the selected logics and sequent calculi. It consists of: - - 1) A uniform traversal algorithm for all logics and target sequent calculi. - This procedure converts classical (intuitionistic) matrix proofs - directly into cut-free "LK" ("LJmc" or "LJ") sequent proofs. - However, the direct construction of "LJ" proofs may fail in some cases - due to proof theoretical reasons. - - 2) A complete redundancy deletion algorithm, which integrates additional - knowledge from the proof search process into the reconstruction process. - This procedure is called by the traversal algorithms in order to avoid - search and deadlocks during proof reconstruciton. - - 3) A permutation-based proof transformation for converting "LJmc" proofs - into "LJ" proofs. - This procedure is called by-need, whenever the direct reconstruction - of "LJ" proofs from matrix proofs fails. - - - - - Literature: - ========== - - JProver system description was presented at CADE 2001: - @InProceedings{inp:Schmitt+01a, - author = "Stephan Schmitt and Lori Lorigo and Christoph Kreitz and - Alexey Nogin", - title = "{{\sf JProver}}: Integrating Connection-based Theorem - Proving into Interactive Proof Assistants", - booktitle = "International Joint Conference on Automated Reasoning", - year = "2001", - editor = "R. Gore and A. Leitsch and T. Nipkow", - volume = 2083, - series = LNAI, - pages = "421--426", - publisher = SPRINGER, - language = English, - where = OWN, - } - - The implementation of JProver is based on the following publications: - - - - Slides of PRL-seminar talks: - --------------------------- - - An Efficient Refiner for First-order Intuitionistic Logic - - http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/feb28.html - - - An Efficient Refiner for First-order Intuitionistic Logic (Part II) - - http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/may22.html - - - - Proof search: - ------------- - - -[1] - @InProceedings{inp:OttenKreitz96b, - author = "J.~Otten and C.~Kreitz", - title = "A uniform proof procedure for classical and - non-classical logics", - booktitle = "Proceedings of the 20$^{th}$ German Annual Conference on - Artificial Intelligence", - year = "1996", - editor = "G.~G{\"o}rz and S.~H{\"o}lldobler", - number = "1137", - series = LNAI, - pages = "307--319", - publisher = SPRINGER - } - - -[2] - @Article{ar:KreitzOtten99, - author = "C.~Kreitz and J.~Otten", - title = "Connection-based theorem proving in classical and - non-classical logics", - journal = "Journal for Universal Computer Science, - Special Issue on Integration of Deductive Systems", - year = "1999", - volume = "5", - number = "3", - pages = "88--112" - } - - - - - Special string unifiation procedure: - ------------------------------------ - - -[3] - @InProceedings{inp:OttenKreitz96a, - author = "J.~Otten and C.~Kreitz", - titl = "T-string-unification: unifying prefixes in - non-classical proof methods", - booktitle = "Proceedings of the 5$^{th}$ Workshop on Theorem Proving - with Analytic Tableaux and Related Methods", - year = 1996, - editor = "U.~Moscato", - number = "1071", - series = LNAI, - pages = "244--260", - publisher = SPRINGER, - month = "May " - } - - - - Proof reconstruction: Uniform traversal algorithm - ------------------------------------------------- - - -[4] - @InProceedings{inp:SchmittKreitz96a, - author = "S.~Schmitt and C.~Kreitz", - title = "Converting non-classical matrix proofs into - sequent-style systems", - booktitle = "Proceedings of the 13$^t{}^h$ Conference on - Automated Deduction", - editor = M.~A.~McRobbie and J.~K.~Slaney", - number = "1104", - series = LNAI, - pages = "418--432", - year = "1996", - publisher = SPRINGER, - month = "July/August" - } - - -[5] - @Article{ar:KreitzSchmitt00, - author = "C.~Kreitz and S.~Schmitt", - title = "A uniform procedure for converting matrix proofs - into sequent-style systems", - journal = "Journal of Information and Computation", - year = "2000", - note = "(to appear)" - } - - -[6] - @Book{bo:Schmitt00, - author = "S.~Schmitt", - title = "Proof reconstruction in classical and non-classical logics", - year = "2000", - publisher = "Infix", - series = "Dissertationen zur K{\"u}nstlichen Intelleigenz", - number = "(to appear)", - note = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt, - FG Intellektik, Germany, 1999)" - } - - The traversal algorithm is presented in the Chapters 2 and 3 of my thesis. - The thesis will be made available for the Department through Christoph Kreitz, - Upson 4159, kreitz@cs.cornell.edu - - - - - Proof reconstruction: Complete redundancy deletion - -------------------------------------------------- - - -[7] - @Book{bo:Schmitt00, - author = "S.~Schmitt", - title = "Proof reconstruction in classical and non-classical logics", - year = "2000", - publisher = "Infix", - series = "Dissertationen zur K{\"u}nstlichen Intelleigenz", - note = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt, - FG Intellektik, Germany, 1999)" - note = "(to appear)", - - } - - The integration of proof knowledge and complete redundancy deletion is presented - in Chapter 4 of my thesis. - - -[8] - @InProceedings{inp:Schmitt00, - author = "S.~Schmitt", - title = "A tableau-like representation framework for efficient - proof reconstruction", - booktitle = "Proceedings of the International Conference on Theorem Proving - with Analytic Tableaux and Related Methods", - year = "2000", - series = LNAI, - publisher = SPRINGER, - month = "June" - note = "(to appear)", - } - - - - - Proof Reconstruction: Permutation-based poof transformations "LJ" -> "LJmc" - --------------------------------------------------------------------------- - - -[9] - @InProceedings{inp:EglySchmitt98, - author = "U.~Egly and S.~Schmitt", - title = "Intuitionistic proof transformations and their - application to constructive program synthesis", - booktitle = "Proceedings of the 4$^{th}$ International Conference - on Artificial Intelligence and Symbolic Computation", - year = "1998", - editor = "J.~Calmet and J.~Plaza", - number = "1476", - series = LNAI, - pages = "132--144", - publisher = SPRINGER, - month = "September" - } - - -[10] - @Article{ar:EglySchmitt99, - author = "U.~Egly and S.~Schmitt", - title = "On intuitionistic proof transformations, their - complexity, and application to constructive program synthesis", - journal = "Fundamenta Informaticae, - Special Issue: Symbolic Computation and Artificial Intelligence", - year = "1999", - volume = "39", - number = "1--2", - pages = "59--83" - } -*) - -(*: open Refiner.Refiner -open Refiner.Refiner.Term -open Refiner.Refiner.TermType -open Refiner.Refiner.TermSubst - -open Jlogic_sig -:*) - -open Jterm -open Opname -open Jlogic - -val ruletable : rule -> string - -module JProver(JLogic: JLogicSig) : -sig - val test : term -> string -> string -> unit - - (* Procedure call: test conclusion logic calculus - - test is applied to a first-order formula. The output is some - formatted sequent proof for test / debugging purposes. - - The arguments for test are as follows: - - logic = "C"|"J" - i.e. first-order classical logic or first-order intuitionistic logic - - calculus = "LK"|"LJ"|"LJmc" - i.e. "LK" for classical logic "C", and either Gentzen's single conclusioned - calculus "LJ" or Fittings multiply-conclusioned calculus "LJmc" for - intuitionistic logic "J". - - term = first-order formula representing the proof goal. - *) - - - - val seqtest : term -> string -> string -> unit - - (* seqtest procedure is for debugging purposes only *) - - - val gen_prover : int option -> string -> string -> term list -> term list -> JLogic.inference - - (* Procedure call: gen_prover mult_limit logic calculus hypothesis conclusion - - The arguments for gen_prover are as follows: - - mult_limit - maximal multiplicity to try, None for unlimited - - logic = same as in test - - calculus = same as in test - - hypothesis = list of first-order terms forming the antecedent of the input sequent - - conclusion = list of first-order terms forming the succedent of the input sequent - This list should contain only one element if logic = "J" and calculus = "LJ". - *) - - - val prover : int option -> term list -> term -> JLogic.inference - - (* Procedure call: gen_prover mult_limit "J" "LJ" hyps [concl] - - prover provides the first-order refiner for NuPRL, using - a single concluisoned succedent [concl] in the sequent. - The result is a sequent proof in the single-conclusioned calculus "LJ". - *) -end diff --git a/contrib/jprover/jlogic.ml b/contrib/jprover/jlogic.ml deleted file mode 100644 index c074e93e..00000000 --- a/contrib/jprover/jlogic.ml +++ /dev/null @@ -1,106 +0,0 @@ -open Opname -open Jterm - -type rule = - | Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl - | Allr | Alll| Exr | Exl | Fail | Falsel | Truer - -let ruletable = function - | Fail -> "Fail" - | Ax -> "Ax" - | Negl -> "Negl" - | Negr -> "Negr" - | Andl -> "Andl" - | Andr -> "Andr" - | Orl -> "Orl" - | Orr -> "Orr" - | Orr1 -> "Orr1" - | Orr2 -> "Orr2" - | Impl -> "Impl" - | Impr -> "Impr" - | Exl -> "Exl" - | Exr -> "Exr" - | Alll -> "Alll" - | Allr -> "Allr" - | Falsel -> "Falsel" - | Truer -> "Truer" - -module type JLogicSig = -sig - (* understanding the input *) - val is_all_term : term -> bool - val dest_all : term -> string * term * term - val is_exists_term : term -> bool - val dest_exists : term -> string * term * term - val is_and_term : term -> bool - val dest_and : term -> term * term - val is_or_term : term -> bool - val dest_or : term -> term * term - val is_implies_term : term -> bool - val dest_implies : term -> term * term - val is_not_term : term -> bool - val dest_not : term -> term - - (* processing the output *) - type inf_step = rule * (string * term) * (string * term) - type inference = inf_step list -(* type inference *) - val empty_inf : inference - val append_inf : inference -> (string * term) -> (string * term) -> rule -> inference - val print_inf : inference -> unit -end;; - -(* Copy from [term_op_std.ml]: *) - - let rec print_address int_list = - match int_list with - | [] -> - Format.print_string "" - | hd::rest -> - begin - Format.print_int hd; - print_address rest - end - -module JLogic: JLogicSig = -struct - let is_all_term = Jterm.is_all_term - let dest_all = Jterm.dest_all - let is_exists_term = Jterm.is_exists_term - let dest_exists = Jterm.dest_exists - let is_and_term = Jterm.is_and_term - let dest_and = Jterm.dest_and - let is_or_term = Jterm.is_or_term - let dest_or = Jterm.dest_or - let is_implies_term = Jterm.is_implies_term - let dest_implies = Jterm.dest_implies - let is_not_term = Jterm.is_not_term - let dest_not = Jterm.dest_not - - type inf_step = rule * (string * term) * (string * term) - type inference = inf_step list - - let empty_inf = [] - let append_inf inf t1 t2 rule = - (rule, t1, t2)::inf - - let rec print_inf inf = - match inf with - | [] -> print_string "."; Format.print_flush () - | (rule, (n1,t1), (n2,t2))::d -> - print_string (ruletable rule); - print_string (":("^n1^":"); - print_term stdout t1; - print_string (","^n2^":"); - print_term stdout t2; - print_string ")\n"; - print_inf d -end;; - -let show_loading s = print_string s -type my_Debug = { mutable debug_name: string; - mutable debug_description: string; - debug_value: bool - } - -let create_debug x = ref false diff --git a/contrib/jprover/jlogic.mli b/contrib/jprover/jlogic.mli deleted file mode 100644 index a9079791..00000000 --- a/contrib/jprover/jlogic.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* The interface to manipulate [jterms], which is - extracted and modified from Meta-Prl. *) - -type rule = - Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl - | Allr | Alll| Exr | Exl | Fail | Falsel | Truer - -module type JLogicSig = - sig - val is_all_term : Jterm.term -> bool - val dest_all : Jterm.term -> string * Jterm.term * Jterm.term - val is_exists_term : Jterm.term -> bool - val dest_exists : Jterm.term -> string * Jterm.term * Jterm.term - val is_and_term : Jterm.term -> bool - val dest_and : Jterm.term -> Jterm.term * Jterm.term - val is_or_term : Jterm.term -> bool - val dest_or : Jterm.term -> Jterm.term * Jterm.term - val is_implies_term : Jterm.term -> bool - val dest_implies : Jterm.term -> Jterm.term * Jterm.term - val is_not_term : Jterm.term -> bool - val dest_not : Jterm.term -> Jterm.term - type inf_step = rule * (string * Jterm.term) * (string * Jterm.term) - type inference = inf_step list - val empty_inf : inference - val append_inf : - inference -> (string * Jterm.term) -> (string * Jterm.term) -> rule -> inference - val print_inf : inference -> unit - end - -module JLogic : JLogicSig - -val show_loading : string -> unit - -type my_Debug = { - mutable debug_name : string; - mutable debug_description : string; - debug_value : bool; -} -val create_debug : 'a -> bool ref -val ruletable : rule -> string diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4 deleted file mode 100644 index 5fd763c3..00000000 --- a/contrib/jprover/jprover.ml4 +++ /dev/null @@ -1,554 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) - -open Jlogic - -module JA = Jall -module JT = Jterm -module T = Tactics -module TCL = Tacticals -module TM = Tacmach -module N = Names -module PT = Proof_type -module HT = Hiddentac -module PA = Pattern -module HP = Hipattern -module TR = Term -module PR = Printer -module RO = Reductionops -module UT = Util -module RA = Rawterm - -module J=JA.JProver(JLogic) (* the JProver *) - -(*i -module NO = Nameops -module TO = Termops -module RE = Reduction -module CL = Coqlib -module ID = Inductiveops -module CV = Clenv -module RF = Refiner -i*) - -(* Interface to JProver: *) -(* type JLogic.inf_step = rule * (string * Jterm.term) * (string * Jterm.term) *) -type jp_inf_step = JLogic.inf_step -type jp_inference = JLogic.inference (* simply a list of [inf_step] *) - -(* Definitions for rebuilding proof tree from JProver: *) -(* leaf, one-branch, two-branch, two-branch, true, false *) -type jpbranch = JP0 | JP1 | JP2 | JP2' | JPT | JPF -type jptree = | JPempty (* empty tree *) - | JPAx of jp_inf_step (* Axiom node *) - | JPA of jp_inf_step * jptree - | JPB of jp_inf_step * jptree * jptree - -(* Private debugging tools: *) -(*i*) -let mbreak s = Format.print_flush (); print_string ("-break at: "^s); - Format.print_flush (); let _ = input_char stdin in () -(*i*) -let jp_error re = raise (JT.RefineError ("jprover", JT.StringError re)) - -(* print Coq constructor *) -let print_constr ct = Pp.ppnl (PR.pr_lconstr ct); Format.print_flush () - -let rec print_constr_list = function - | [] -> () - | ct::r -> print_constr ct; print_constr_list r - -let print_constr_pair op c1 c2 = - print_string (op^"("); - print_constr c1; - print_string ","; - print_constr c2; - print_string ")\n" - - -(* Parsing modules for Coq: *) -(* [is_coq_???] : testing functions *) -(* [dest_coq_???] : destructors *) - -let is_coq_true ct = (HP.is_unit_type ct) && not (HP.is_equation ct) - -let is_coq_false = HP.is_empty_type - -(* return two subterms *) -let dest_coq_and ct = - match (HP.match_with_conjunction ct) with - | Some (hdapp,args) -> -(*i print_constr hdapp; print_constr_list args; i*) - begin - match args with - | s1::s2::[] -> -(*i print_constr_pair "and" s1 s2; i*) - (s1,s2) - | _ -> jp_error "dest_coq_and" - end - | None -> jp_error "dest_coq_and" - -let is_coq_or = HP.is_disjunction - -(* return two subterms *) -let dest_coq_or ct = - match (HP.match_with_disjunction ct) with - | Some (hdapp,args) -> -(*i print_constr hdapp; print_constr_list args; i*) - begin - match args with - | s1::s2::[] -> -(*i print_constr_pair "or" s1 s2; i*) - (s1,s2) - | _ -> jp_error "dest_coq_or" - end - | None -> jp_error "dest_coq_or" - -let is_coq_not = HP.is_nottype - -let dest_coq_not ct = - match (HP.match_with_nottype ct) with - | Some (hdapp,arg) -> -(*i print_constr hdapp; print_constr args; i*) -(*i print_string "not "; - print_constr arg; i*) - arg - | None -> jp_error "dest_coq_not" - - -let is_coq_impl ct = - match TR.kind_of_term ct with - | TR.Prod (_,_,b) -> (not (Termops.dependent (TR.mkRel 1) b)) - | _ -> false - - -let dest_coq_impl c = - match TR.kind_of_term c with - | TR.Prod (_,b,c) -> -(*i print_constr_pair "impl" b c; i*) - (b, c) - | _ -> jp_error "dest_coq_impl" - -(* provide new variables for renaming of universal variables *) -let new_counter = - let ctr = ref 0 in - fun () -> incr ctr;!ctr - -(* provide new symbol name for unknown Coq constructors *) -let new_ecounter = - let ectr = ref 0 in - fun () -> incr ectr;!ectr - -(* provide new variables for address naming *) -let new_acounter = - let actr = ref 0 in - fun () -> incr actr;!actr - -let is_coq_forall ct = - match TR.kind_of_term (RO.whd_betaiota ct) with - | TR.Prod (_,_,b) -> Termops.dependent (TR.mkRel 1) b - | _ -> false - -(* return the bounded variable (as a string) and the bounded term *) -let dest_coq_forall ct = - match TR.kind_of_term (RO.whd_betaiota ct) with - | TR.Prod (_,_,b) -> - let x ="jp_"^(string_of_int (new_counter())) in - let v = TR.mkVar (N.id_of_string x) in - let c = TR.subst1 v b in (* substitute de Bruijn variable by [v] *) -(*i print_constr_pair "forall" v c; i*) - (x, c) - | _ -> jp_error "dest_coq_forall" - - -(* Apply [ct] to [t]: *) -let sAPP ct t = - match TR.kind_of_term (RO.whd_betaiota ct) with - | TR.Prod (_,_,b) -> - let c = TR.subst1 t b in - c - | _ -> jp_error "sAPP" - - -let is_coq_exists ct = - if not (HP.is_conjunction ct) then false - else let (hdapp,args) = TR.decompose_app ct in - match args with - | _::la::[] -> - begin - try - match TR.destLambda la with - | (N.Name _,_,_) -> true - | _ -> false - with _ -> false - end - | _ -> false - -(* return the bounded variable (as a string) and the bounded term *) -let dest_coq_exists ct = - let (hdapp,args) = TR.decompose_app ct in - match args with - | _::la::[] -> - begin - try - match TR.destLambda la with - | (N.Name x,t1,t2) -> - let v = TR.mkVar x in - let t3 = TR.subst1 v t2 in -(*i print_constr_pair "exists" v t3; i*) - (N.string_of_id x, t3) - | _ -> jp_error "dest_coq_exists" - with _ -> jp_error "dest_coq_exists" - end - | _ -> jp_error "dest_coq_exists" - - -let is_coq_and ct = - if (HP.is_conjunction ct) && not (is_coq_exists ct) - && not (is_coq_true ct) then true - else false - - -(* Parsing modules: *) - -let jtbl = Hashtbl.create 53 (* associate for unknown Coq constr. *) -let rtbl = Hashtbl.create 53 (* reverse table of [jtbl] *) - -let dest_coq_symb ct = - N.string_of_id (TR.destVar ct) - -(* provide new names for unknown Coq constr. *) -(* [ct] is the unknown constr., string [s] is appended to the name encoding *) -let create_coq_name ct s = - try - Hashtbl.find jtbl ct - with Not_found -> - let t = ("jp_"^s^(string_of_int (new_ecounter()))) in - Hashtbl.add jtbl ct t; - Hashtbl.add rtbl t ct; - t - -let dest_coq_app ct s = - let (hd, args) = TR.decompose_app ct in -(*i print_constr hd; - print_constr_list args; i*) - if TR.isVar hd then - (dest_coq_symb hd, args) - else (* unknown constr *) - (create_coq_name hd s, args) - -let rec parsing2 c = (* for function symbols, variables, constants *) - if (TR.isApp c) then (* function symbol? *) - let (f,args) = dest_coq_app c "fun_" in - JT.fun_ f (List.map parsing2 args) - else if TR.isVar c then (* identifiable variable or constant *) - JT.var_ (dest_coq_symb c) - else (* unknown constr *) - JT.var_ (create_coq_name c "var_") - -(* the main parsing function *) -let rec parsing c = - let ct = Reduction.whd_betadeltaiota (Global.env ()) c in -(* let ct = Reduction.whd_betaiotazeta (Global.env ()) c in *) - if is_coq_true ct then - JT.true_ - else if is_coq_false ct then - JT.false_ - else if is_coq_not ct then - JT.not_ (parsing (dest_coq_not ct)) - else if is_coq_impl ct then - let (t1,t2) = dest_coq_impl ct in - JT.imp_ (parsing t1) (parsing t2) - else if is_coq_or ct then - let (t1,t2) = dest_coq_or ct in - JT.or_ (parsing t1) (parsing t2) - else if is_coq_and ct then - let (t1,t2) = dest_coq_and ct in - JT.and_ (parsing t1) (parsing t2) - else if is_coq_forall ct then - let (v,t) = dest_coq_forall ct in - JT.forall v (parsing t) - else if is_coq_exists ct then - let (v,t) = dest_coq_exists ct in - JT.exists v (parsing t) - else if TR.isApp ct then (* predicate symbol with arguments *) - let (p,args) = dest_coq_app ct "P_" in - JT.pred_ p (List.map parsing2 args) - else if TR.isVar ct then (* predicate symbol without arguments *) - let p = dest_coq_symb ct in - JT.pred_ p [] - else (* unknown predicate *) - JT.pred_ (create_coq_name ct "Q_") [] - -(*i - print_string "??";print_constr ct; - JT.const_ ("err_"^(string_of_int (new_ecounter()))) -i*) - - -(* Translate JProver terms into Coq constructors: *) -(* The idea is to retrieve it from [rtbl] if it exists indeed, otherwise - create one. *) -let rec constr_of_jterm t = - if (JT.is_var_term t) then (* a variable *) - let v = JT.dest_var t in - try - Hashtbl.find rtbl v - with Not_found -> TR.mkVar (N.id_of_string v) - else if (JT.is_fun_term t) then (* a function symbol *) - let (f,ts) = JT.dest_fun t in - let f' = try Hashtbl.find rtbl f with Not_found -> TR.mkVar (N.id_of_string f) in - TR.mkApp (f', Array.of_list (List.map constr_of_jterm ts)) - else jp_error "constr_of_jterm" - - -(* Coq tactics for Sequent Calculus LJ: *) -(* Note that for left-rule a name indicating the being applied rule - in Coq's Hints is required; for right-rule a name is also needed - if it will pass some subterm to the left-hand side. - However, all of these can be computed by the path [id] of the being - applied rule. -*) - -let assoc_addr = Hashtbl.create 97 - -let short_addr s = - let ad = - try - Hashtbl.find assoc_addr s - with Not_found -> - let t = ("jp_H"^(string_of_int (new_acounter()))) in - Hashtbl.add assoc_addr s t; - t - in - N.id_of_string ad - -(* and-right *) -let dyn_andr = - T.split RA.NoBindings - -(* For example, the following implements the [and-left] rule: *) -let dyn_andl id = (* [id1]: left child; [id2]: right child *) - let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in - (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id))) (T.intros_using [id1;id2])) - -let dyn_orr1 = - T.left RA.NoBindings - -let dyn_orr2 = - T.right RA.NoBindings - -let dyn_orl id = - let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in - (TCL.tclTHENS (T.simplest_elim (TR.mkVar (short_addr id))) - [T.intro_using id1; T.intro_using id2]) - -let dyn_negr id = - let id1 = id^"_1_1" in - HT.h_intro (short_addr id1) - -let dyn_negl id = - T.simplest_elim (TR.mkVar (short_addr id)) - -let dyn_impr id = - let id1 = id^"_1_1" in - HT.h_intro (short_addr id1) - -let dyn_impl id gl = - let t = TM.pf_get_hyp_typ gl (short_addr id) in - let ct = Reduction.whd_betadeltaiota (Global.env ()) t in (* unfolding *) - let (_,b) = dest_coq_impl ct in - let id2 = (short_addr (id^"_1_2")) in - (TCL.tclTHENLAST - (TCL.tclTHENS (T.cut b) [T.intro_using id2;TCL.tclIDTAC]) - (T.apply_term (TR.mkVar (short_addr id)) - [TR.mkMeta (Evarutil.new_meta())])) gl - -let dyn_allr c = (* [c] must be an eigenvariable which replaces [v] *) - HT.h_intro (N.id_of_string c) - -(* [id2] is the path of the instantiated term for [id]*) -let dyn_alll id id2 t gl = - let id' = short_addr id in - let id2' = short_addr id2 in - let ct = TM.pf_get_hyp_typ gl id' in - let ct' = Reduction.whd_betadeltaiota (Global.env ()) ct in (* unfolding *) - let ta = sAPP ct' t in - TCL.tclTHENS (T.cut ta) [T.intro_using id2'; T.apply (TR.mkVar id')] gl - -let dyn_exl id id2 c = (* [c] must be an eigenvariable *) - (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id))) - (T.intros_using [(N.id_of_string c);(short_addr id2)])) - -let dyn_exr t = - T.one_constructor 1 (RA.ImplicitBindings [t]) - -let dyn_falsel = dyn_negl - -let dyn_truer = - T.one_constructor 1 RA.NoBindings - -(* Do the proof by the guidance of JProver. *) - -let do_one_step inf = - let (rule, (s1, t1), (s2, t2)) = inf in - begin -(*i if not (Jterm.is_xnil_term t2) then - begin - print_string "1: "; JT.print_term stdout t2; print_string "\n"; - print_string "2: "; print_constr (constr_of_jterm t2); print_string "\n"; - end; -i*) - match rule with - | Andl -> dyn_andl s1 - | Andr -> dyn_andr - | Orl -> dyn_orl s1 - | Orr1 -> dyn_orr1 - | Orr2 -> dyn_orr2 - | Impr -> dyn_impr s1 - | Impl -> dyn_impl s1 - | Negr -> dyn_negr s1 - | Negl -> dyn_negl s1 - | Allr -> dyn_allr (JT.dest_var t2) - | Alll -> dyn_alll s1 s2 (constr_of_jterm t2) - | Exr -> dyn_exr (Tactics.inj_open (constr_of_jterm t2)) - | Exl -> dyn_exl s1 s2 (JT.dest_var t2) - | Ax -> T.assumption (*i TCL.tclIDTAC i*) - | Truer -> dyn_truer - | Falsel -> dyn_falsel s1 - | _ -> jp_error "do_one_step" - (* this is impossible *) - end -;; - -(* Parameter [tr] is the reconstucted proof tree from output of JProver. *) -let do_coq_proof tr = - let rec rec_do trs = - match trs with - | JPempty -> TCL.tclIDTAC - | JPAx h -> do_one_step h - | JPA (h, t) -> TCL.tclTHEN (do_one_step h) (rec_do t) - | JPB (h, left, right) -> TCL.tclTHENS (do_one_step h) [rec_do left; rec_do right] - in - rec_do tr - - -(* Rebuild the proof tree from the output of JProver: *) - -(* Since some universal variables are not necessarily first-order, - lazy substitution may happen. They are recorded in [rtbl]. *) -let reg_unif_subst t1 t2 = - let (v,_,_) = JT.dest_all t1 in - Hashtbl.add rtbl v (TR.mkVar (N.id_of_string (JT.dest_var t2))) - -let count_jpbranch one_inf = - let (rule, (_, t1), (_, t2)) = one_inf in - begin - match rule with - | Ax -> JP0 - | Orr1 | Orr2 | Negl | Impr | Alll | Exr | Exl -> JP1 - | Andr | Orl -> JP2 - | Negr -> if (JT.is_true_term t1) then JPT else JP1 - | Andl -> if (JT.is_false_term t1) then JPF else JP1 - | Impl -> JP2' (* reverse the sons of [Impl] since [dyn_impl] reverses them *) - | Allr -> reg_unif_subst t1 t2; JP1 - | _ -> jp_error "count_jpbranch" - end - -let replace_by r = function - (rule, a, b) -> (r, a, b) - -let rec build_jptree inf = - match inf with - | [] -> ([], JPempty) - | h::r -> - begin - match count_jpbranch h with - | JP0 -> (r,JPAx h) - | JP1 -> let (r1,left) = build_jptree r in - (r1, JPA(h, left)) - | JP2 -> let (r1,left) = build_jptree r in - let (r2,right) = build_jptree r1 in - (r2, JPB(h, left, right)) - | JP2' -> let (r1,left) = build_jptree r in (* for [Impl] *) - let (r2,right) = build_jptree r1 in - (r2, JPB(h, right, left)) - | JPT -> let (r1,left) = build_jptree r in (* right True *) - (r1, JPAx (replace_by Truer h)) - | JPF -> let (r1,left) = build_jptree r in (* left False *) - (r1, JPAx (replace_by Falsel h)) - end - - -(* The main function: *) -(* [limits] is the multiplicity limit. *) -let jp limits gls = - let concl = TM.pf_concl gls in - let ct = concl in -(*i print_constr ct; i*) - Hashtbl.clear jtbl; (* empty the hash tables *) - Hashtbl.clear rtbl; - Hashtbl.clear assoc_addr; - let t = parsing ct in -(*i JT.print_term stdout t; i*) - try - let p = (J.prover limits [] t) in -(*i print_string "\n"; - JLogic.print_inf p; i*) - let (il,tr) = build_jptree p in - if (il = []) then - begin - Pp.msgnl (Pp.str "Proof is built."); - do_coq_proof tr gls - end - else UT.error "Cannot reconstruct proof tree from JProver." - with e -> Pp.msgnl (Pp.str "JProver fails to prove this:"); - JT.print_error_msg e; - UT.error "JProver terminated." - -(* an unfailed generalization procedure *) -let non_dep_gen b gls = - let concl = TM.pf_concl gls in - if (not (Termops.dependent b concl)) then - T.generalize [b] gls - else - TCL.tclIDTAC gls - -let rec unfail_gen = function - | [] -> TCL.tclIDTAC - | h::r -> - TCL.tclTHEN - (TCL.tclORELSE (non_dep_gen h) (TCL.tclIDTAC)) - (unfail_gen r) - -(* -(* no argument, which stands for no multiplicity limit *) -let jp gls = - let ls = List.map (fst) (TM.pf_hyps_types gls) in -(*i T.generalize (List.map TR.mkVar ls) gls i*) - (* generalize the context *) - TCL.tclTHEN (TCL.tclTRY T.red_in_concl) - (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls)) - (jp None)) gls -*) -(* -let dyn_jp l gls = - assert (l = []); - jp -*) - -(* one optional integer argument for the multiplicity *) -let jpn n gls = - let ls = List.map (fst) (TM.pf_hyps_types gls) in - TCL.tclTHEN (TCL.tclTRY T.red_in_concl) - (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls)) - (jp n)) gls - -TACTIC EXTEND jprover - [ "jp" natural_opt(n) ] -> [ jpn n ] -END - -(* -TACTIC EXTEND Andl - [ "Andl" ident(id)] -> [ ... (Andl id) ... ]. -END -*) diff --git a/contrib/jprover/jterm.ml b/contrib/jprover/jterm.ml deleted file mode 100644 index 7fc923a5..00000000 --- a/contrib/jprover/jterm.ml +++ /dev/null @@ -1,872 +0,0 @@ -open Printf -open Opname -open List - -(* Definitions of [jterm]: *) -type param = param' - and operator = operator' - and term = term' - and bound_term = bound_term' - and param' = - | Number of int - | String of string - | Token of string - | Var of string - | ParamList of param list - and operator' = { op_name : opname; op_params : param list } - and term' = { term_op : operator; term_terms : bound_term list } - and bound_term' = { bvars : string list; bterm : term } -;; - -(* Debugging tools: *) -(*i*) -let mbreak s = Format.print_flush (); print_string ("-break at: "^s); - Format.print_flush (); let _ = input_char stdin in () -(*i*) - -type error_msg = - | TermMatchError of term * string - | StringError of string - -exception RefineError of string * error_msg - -let ref_raise = function - | RefineError(s,e) -> raise (RefineError(s,e)) - | _ -> raise (RefineError ("Jterm", StringError "unexpected error")) - -(* Printing utilities: *) - -let fprint_str ostream s = - let _ = fprintf ostream "%s." s in ostream - -let fprint_str_list ostream sl = - ignore (List.fold_left fprint_str ostream sl); - Format.print_flush () - -let fprint_opname ostream = function - { opname_token= tk; opname_name = sl } -> - fprint_str_list ostream sl - -let rec fprint_param ostream = function - | Number n -> fprintf ostream " %d " n - | String s -> fprint_str_list ostream [s] - | Token t -> fprint_str_list ostream [t] - | Var v -> fprint_str_list ostream [v] - | ParamList ps -> fprint_param_list ostream ps -and fprint_param_list ostream = function - | [] -> () - | param::r -> fprint_param ostream param; - fprint_param_list ostream r -;; - -let print_strs = fprint_str_list stdout - - -(* Interface to [Jall.ml]: *) -(* It is extracted from Meta-Prl's standard implementation. *) -(*c begin of the extraction *) - -type term_subst = (string * term) list -let mk_term op bterms = { term_op = op; term_terms = bterms } -let make_term x = x (* external [make_term : term' -> term] = "%identity" *) -let dest_term x = x (* external [dest_term : term -> term'] = "%identity" *) -let mk_op name params = - { op_name = name; op_params = params } - -let make_op x = x (* external [make_op : operator' -> operator] = "%identity" *) -let dest_op x = x (* external [dest_op : operator -> operator'] = "%identity" *) -let mk_bterm bvars term = { bvars = bvars; bterm = term } -let make_bterm x = x (* external [make_bterm : bound_term' -> bound_term] = "%identity" *) -let dest_bterm x = x (* external [dest_bterm : bound_term -> bound_term'] = "%identity" *) -let make_param x = x (* external [make_param : param' -> param] = "%identity" *) -let dest_param x = x (* external [dest_param : param -> param'] = "%identity" *) - -(* - * Operator names. - *) -let opname_of_term = function - { term_op = { op_name = name } } -> - name - -(* - * Get the subterms. - * None of the subterms should be bound. - *) -let subterms_of_term t = - List.map (fun { bterm = t } -> t) t.term_terms - -let subterm_count { term_terms = terms } = - List.length terms - -let subterm_arities { term_terms = terms } = - List.map (fun { bvars = vars } -> List.length vars) terms - -(* - * Manifest terms are injected into the "perv" module. - *) -let xperv = make_opname ["Perv"] -let sequent_opname = mk_opname "sequent" xperv - -(* - * Variables. - *) - -let var_opname = make_opname ["var"] - -(* - * See if a term is a variable. - *) -let is_var_term = function - | { term_op = { op_name = opname; op_params = [Var v] }; - term_terms = [] - } when Opname.eq opname var_opname -> true - | _ -> - false - -(* - * Destructor for a variable. - *) -let dest_var = function - | { term_op = { op_name = opname; op_params = [Var v] }; - term_terms = [] - } when Opname.eq opname var_opname -> v - | t -> - ref_raise(RefineError ("dest_var", TermMatchError (t, "not a variable"))) -(* - * Make a variable. - *) -let mk_var_term v = - { term_op = { op_name = var_opname; op_params = [Var v] }; - term_terms = [] - } - -(* - * Simple terms - *) -(* - * "Simple" terms have no parameters and no binding variables. - *) -let is_simple_term_opname name = function - | { term_op = { op_name = name'; op_params = [] }; - term_terms = bterms - } when Opname.eq name' name -> - let rec aux = function - | { bvars = []; bterm = _ }::t -> aux t - | _::t -> false - | [] -> true - in - aux bterms - | _ -> false - -let mk_any_term op terms = - let aux t = - { bvars = []; bterm = t } - in - { term_op = op; term_terms = List.map aux terms } - -let mk_simple_term name terms = - mk_any_term { op_name = name; op_params = [] } terms - -let dest_simple_term = function - | ({ term_op = { op_name = name; op_params = [] }; - term_terms = bterms - } : term) as t -> - let aux = function - | { bvars = []; bterm = t } -> - t - | _ -> - ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "binding vars exist"))) - in - name, List.map aux bterms - | t -> - ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "params exist"))) - -let dest_simple_term_opname name = function - | ({ term_op = { op_name = name'; op_params = [] }; - term_terms = bterms - } : term) as t -> - if Opname.eq name name' then - let aux = function - | { bvars = []; bterm = t } -> t - | _ -> ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "binding vars exist"))) - in - List.map aux bterms - else - ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "opname mismatch"))) - | t -> - ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "params exist"))) - -(* - * Bound terms. - *) -let mk_simple_bterm bterm = - { bvars = []; bterm = bterm } - -let dest_simple_bterm = function - | { bvars = []; bterm = bterm } -> - bterm - | _ -> - ref_raise(RefineError ("dest_simple_bterm", StringError ("bterm is not simple"))) - -(* Copy from [term_op_std.ml]: *) -(*i modified for Jprover, as a patch... i*) -let mk_string_term opname s = - { term_op = { op_name = opname; op_params = [String s] }; term_terms = [] } - -(*i let mk_string_term opname s = - let new_opname={opname_token=opname.opname_token; opname_name=(List.tl opname.opname_name)@[s]} in - { term_op = { op_name = new_opname; op_params = [String (List.hd opname.opname_name)] }; term_terms = [] } -i*) - -(* Copy from [term_subst_std.ml]: *) - -let rec free_vars_term gvars bvars = function - | { term_op = { op_name = opname; op_params = [Var v] }; term_terms = bterms } when Opname.eq opname var_opname -> - (* This is a variable *) - let gvars' = - if List.mem v bvars or List.mem v gvars then - gvars - else - v::gvars - in - free_vars_bterms gvars' bvars bterms - | { term_terms = bterms } -> - free_vars_bterms gvars bvars bterms - and free_vars_bterms gvars bvars = function - | { bvars = vars; bterm = term}::l -> - let bvars' = vars @ bvars in - let gvars' = free_vars_term gvars bvars' term in - free_vars_bterms gvars' bvars l - | [] -> - gvars - -let free_vars_list = free_vars_term [] [] - - -(* Termop: *) - -let is_no_subterms_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [] - } -> - Opname.eq opname' opname - | _ -> - false - -(* - * Terms with one subterm. - *) -let is_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = [] }] - } -> Opname.eq opname' opname - | _ -> false - -let mk_dep0_term opname t = - { term_op = { op_name = opname; op_params = [] }; - term_terms = [{ bvars = []; bterm = t }] - } - -let dest_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = []; bterm = t }] - } when Opname.eq opname' opname -> t - | t -> ref_raise(RefineError ("dest_dep0_term", TermMatchError (t, "not a dep0 term"))) - -(* - * Terms with two subterms. - *) -let is_dep0_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = [] }; { bvars = [] }] - } -> Opname.eq opname' opname - | _ -> false - -let mk_dep0_dep0_term opname = fun - t1 t2 -> - { term_op = { op_name = opname; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = []; bterm = t2 }] - } - -let dest_dep0_dep0_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = []; bterm = t2 }] - } when Opname.eq opname' opname -> t1, t2 - | t -> ref_raise(RefineError ("dest_dep0_dep0_term", TermMatchError (t, "bad arity"))) - -(* - * Bound term. - *) - -let is_dep0_dep1_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = [] }; { bvars = [_] }] - } when Opname.eq opname' opname -> true - | _ -> false - -let is_dep0_dep1_any_term = function - | { term_op = { op_params = [] }; - term_terms = [{ bvars = [] }; { bvars = [_] }] - } -> true - | _ -> false - -let mk_dep0_dep1_term opname = fun - v t1 t2 -> { term_op = { op_name = opname; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = [v]; bterm = t2 }] - } - -let dest_dep0_dep1_term opname = function - | { term_op = { op_name = opname'; op_params = [] }; - term_terms = [{ bvars = []; bterm = t1 }; - { bvars = [v]; bterm = t2 }] - } when Opname.eq opname' opname -> v, t1, t2 - | t -> ref_raise(RefineError ("dest_dep0_dep1_term", TermMatchError (t, "bad arity"))) - -let rec smap f = function - | [] -> [] - | (hd::tl) as l -> - let hd' = f hd in - let tl' = smap f tl in - if (hd==hd')&&(tl==tl') then l else hd'::tl' - -let rec try_check_assoc v v' = function - | [] -> raise Not_found - | (v1,v2)::tl -> - begin match v=v1, v'=v2 with - | true, true -> true - | false, false -> try_check_assoc v v' tl - | _ -> false - end - -let rec zip_list l l1 l2 = match (l1,l2) with - | (h1::t1), (h2::t2) -> - zip_list ((h1,h2)::l) t1 t2 - | [], [] -> - l - | _ -> raise (Failure "Term.zip_list") - -let rec assoc_in_range eq y = function - | (_, y')::tl -> - (eq y y') || (assoc_in_range eq y tl) - | [] -> - false - -let rec check_assoc v v' = function - | [] -> v=v' - | (v1,v2)::tl -> - begin match v=v1, v'=v2 with - | true, true -> true - | false, false -> check_assoc v v' tl - | _ -> false - end - -let rec zip a b = match (a,b) with - | (h1::t1), (h2::t2) -> - (h1, h2) :: zip t1 t2 - | [], [] -> - [] - | - _ -> raise (Failure "Term.zip") - -let rec for_all2 f l1 l2 = - match (l1,l2) with - | h1::t1, h2::t2 -> for_all2 f t1 t2 & f h1 h2 - | [], [] -> true - | _ -> false - -let newname v i = - v ^ "_" ^ (string_of_int i) - -let rec new_var v avoid i = - let v' = newname v i in - if avoid v' - then new_var v avoid (succ i) - else v' - -let vnewname v avoid = new_var v avoid 1 - -let rev_mem a b = List.mem b a - -let rec find_index_aux v i = function - | h::t -> - if h = v then - i - else - find_index_aux v (i + 1) t - | [] -> - raise Not_found - -let find_index v l = find_index_aux v 0 l - -let rec remove_elements l1 l2 = - match l1, l2 with - | flag::ft, h::t -> - if flag then - remove_elements ft t - else - h :: remove_elements ft t - | _, l -> - l - -let rec subtract l1 l2 = - match l1 with - | h::t -> - if List.mem h l2 then - subtract t l2 - else - h :: subtract t l2 - | [] -> - [] - -let rec fv_mem fv v = - match fv with - | [] -> false - | h::t -> - List.mem v h || fv_mem t v - -let rec new_vars fv = function - | [] -> [] - | v::t -> - (* Rename the first one, then add it to free vars *) - let v' = vnewname v (fv_mem fv) in - v'::(new_vars ([v']::fv) t) - -let rec fsubtract l = function - | [] -> l - | h::t -> - fsubtract (subtract l h) t - -let add_renames_fv r l = - let rec aux = function - | [] -> l - | v::t -> [v]::(aux t) - in - aux r - -let add_renames_terms r l = - let rec aux = function - | [] -> l - | v::t -> (mk_var_term v)::(aux t) - in - aux r - -(* - * First order simultaneous substitution. - *) -let rec subst_term terms fv vars = function - | { term_op = { op_name = opname; op_params = [Var(v)] }; term_terms = [] } as t - when Opname.eq opname var_opname-> - (* Var case *) - begin - try List.nth terms (find_index v vars) with - Not_found -> - t - end - | { term_op = op; term_terms = bterms } -> - (* Other term *) - { term_op = op; term_terms = subst_bterms terms fv vars bterms } - -and subst_bterms terms fv vars bterms = - (* When subst through bterms, catch binding occurrences *) - let rec subst_bterm = function - | { bvars = []; bterm = term } -> - (* Optimize the common case *) - { bvars = []; bterm = subst_term terms fv vars term } - - | { bvars = bvars; bterm = term } -> - (* First subtract bound instances *) - let flags = List.map (function v -> List.mem v bvars) vars in - let vars' = remove_elements flags vars in - let fv' = remove_elements flags fv in - let terms' = remove_elements flags terms in - - (* If any of the binding variables are free, rename them *) - let renames = subtract bvars (fsubtract bvars fv') in - if renames <> [] then - let fv'' = (free_vars_list term)::fv' in - let renames' = new_vars fv'' renames in - { bvars = subst_bvars renames' renames bvars; - bterm = subst_term - (add_renames_terms renames' terms') - (add_renames_fv renames' fv') - (renames @ vars') - term - } - else - { bvars = bvars; - bterm = subst_term terms' fv' vars' term - } - in - List.map subst_bterm bterms - -and subst_bvars renames' renames bvars = - let subst_bvar v = - try List.nth renames' (find_index v renames) with - Not_found -> v - in - List.map subst_bvar bvars - -let subst term vars terms = - subst_term terms (List.map free_vars_list terms) vars term - -(*i bug!!! in the [term_std] module - let subst1 t var term = - let fv = free_vars_list term in - if List.mem var fv then - subst_term [term] [fv] [var] t - else - t -The following is the correct implementation -i*) - -let subst1 t var term = -if List.mem var (free_vars_list t) then - subst_term [term] [free_vars_list term] [var] t -else - t - -let apply_subst t s = - let vs,ts = List.split s in - subst t vs ts - -let rec equal_params p1 p2 = - match p1, p2 with - | Number n1, Number n2 -> - n1 = n2 - | ParamList pl1, ParamList pl2 -> - List.for_all2 equal_params pl1 pl2 - | _ -> - p1 = p2 - -let rec equal_term vars t t' = - match t, t' with - | { term_op = { op_name = opname1; op_params = [Var v] }; - term_terms = [] - }, - { term_op = { op_name = opname2; op_params = [Var v'] }; - term_terms = [] - } when Opname.eq opname1 var_opname & Opname.eq opname2 var_opname -> - check_assoc v v' vars - | { term_op = { op_name = name1; op_params = params1 }; term_terms = bterms1 }, - { term_op = { op_name = name2; op_params = params2 }; term_terms = bterms2 } -> - (Opname.eq name1 name2) - & (for_all2 equal_params params1 params2) - & (equal_bterms vars bterms1 bterms2) -and equal_bterms vars bterms1 bterms2 = - let equal_bterm = fun - { bvars = bvars1; bterm = term1 } - { bvars = bvars2; bterm = term2 } -> - equal_term (zip_list vars bvars1 bvars2) term1 term2 - in - for_all2 equal_bterm bterms1 bterms2 - - -let alpha_equal t1 t2 = - try equal_term [] t1 t2 with Failure _ -> false - -let var_subst t t' v = - let { term_op = { op_name = opname } } = t' in - let vt = mk_var_term v in - let rec subst_term = function - { term_op = { op_name = opname'; op_params = params }; - term_terms = bterms - } as t -> - (* Check if this is the same *) - if Opname.eq opname' opname & alpha_equal t t' then - vt - else - { term_op = { op_name = opname'; op_params = params }; - term_terms = List.map subst_bterm bterms - } - - and subst_bterm { bvars = vars; bterm = term } = - if List.mem v vars then - let av = vars @ (free_vars_list term) in - let v' = vnewname v (fun v -> List.mem v av) in - let rename var = if var = v then v' else var in - let term = subst1 term v (mk_var_term v') in - { bvars = smap rename vars; bterm = subst_term term } - else - { bvars = vars; bterm = subst_term term } - in - subst_term t - -let xnil_opname = mk_opname "nil" xperv -let xnil_term = mk_simple_term xnil_opname [] -let is_xnil_term = is_no_subterms_term xnil_opname - -(*c End of the extraction from Meta-Prl *) - -(* Huang's modification: *) -let all_opname = make_opname ["quantifier";"all"] -let is_all_term = is_dep0_dep1_term all_opname -let dest_all = dest_dep0_dep1_term all_opname -let mk_all_term = mk_dep0_dep1_term all_opname - -let exists_opname = make_opname ["quantifier";"exst"] -let is_exists_term = is_dep0_dep1_term exists_opname -let dest_exists = dest_dep0_dep1_term exists_opname -let mk_exists_term = mk_dep0_dep1_term exists_opname - -let or_opname = make_opname ["connective";"or"] -let is_or_term = is_dep0_dep0_term or_opname -let dest_or = dest_dep0_dep0_term or_opname -let mk_or_term = mk_dep0_dep0_term or_opname - -let and_opname = make_opname ["connective";"and"] -let is_and_term = is_dep0_dep0_term and_opname -let dest_and = dest_dep0_dep0_term and_opname -let mk_and_term = mk_dep0_dep0_term and_opname - -let cor_opname = make_opname ["connective";"cor"] -let is_cor_term = is_dep0_dep0_term cor_opname -let dest_cor = dest_dep0_dep0_term cor_opname -let mk_cor_term = mk_dep0_dep0_term cor_opname - -let cand_opname = make_opname ["connective";"cand"] -let is_cand_term = is_dep0_dep0_term cand_opname -let dest_cand = dest_dep0_dep0_term cand_opname -let mk_cand_term = mk_dep0_dep0_term cand_opname - -let implies_opname = make_opname ["connective";"=>"] -let is_implies_term = is_dep0_dep0_term implies_opname -let dest_implies = dest_dep0_dep0_term implies_opname -let mk_implies_term = mk_dep0_dep0_term implies_opname - -let iff_opname = make_opname ["connective";"iff"] -let is_iff_term = is_dep0_dep0_term iff_opname -let dest_iff = dest_dep0_dep0_term iff_opname -let mk_iff_term = mk_dep0_dep0_term iff_opname - -let not_opname = make_opname ["connective";"not"] -let is_not_term = is_dep0_term not_opname -let dest_not = dest_dep0_term not_opname -let mk_not_term = mk_dep0_term not_opname - -let var_ = mk_var_term -let fun_opname = make_opname ["function"] -let fun_ f ts = mk_any_term {op_name = fun_opname; op_params = [String f] } ts - -let is_fun_term = function - | { term_op = { op_name = opname; op_params = [String f] }} - when Opname.eq opname fun_opname -> true - | _ -> - false - -let dest_fun = function - | { term_op = { op_name = opname; op_params = [String f] }; term_terms = ts} - when Opname.eq opname fun_opname -> (f, List.map (fun { bterm = t } -> t) ts) - | t -> - ref_raise(RefineError ("dest_fun", TermMatchError (t, "not a function symbol"))) - -let const_ c = fun_ c [] -let is_const_term = function - | { term_op = { op_name = opname; op_params = [String f] }; term_terms = [] } - when Opname.eq opname fun_opname -> true - | _ -> - false - -let dest_const t = - let (n, ts) = dest_fun t in n - -let pred_opname = make_opname ["predicate"] -let pred_ p ts = mk_any_term {op_name = pred_opname; op_params = [String p] } ts - -let not_ = mk_not_term -let and_ = mk_and_term -let or_ = mk_or_term -let imp_ = mk_implies_term -let cand_ = mk_cand_term -let cor_ = mk_cor_term -let iff_ = mk_iff_term -let nil_term = {term_op={op_name=nil_opname; op_params=[]}; term_terms=[] } -let forall v t = mk_all_term v nil_term t -let exists v t= mk_exists_term v nil_term t -let rec wbin op = function - | [] -> raise (Failure "Term.wbin") - | [t] -> t - | t::r -> op t (wbin op r) - -let wand_ = wbin and_ -let wor_ = wbin or_ -let wimp_ = wbin imp_ - -(*i let true_opname = make_opname ["bool";"true"] -let is_true_term = is_no_subterms_term true_opname -let true_ = mk_simple_term true_opname [] -let false_ = not_ true_ - -let is_false_term t = - if is_not_term t then - let t1 = dest_not t in - is_true_term t1 - else - false -i*) - -let dummy_false_ = mk_simple_term (make_opname ["bool";"false"]) [] -let dummy_true_ = mk_simple_term (make_opname ["bool";"true"]) [] -let false_ = and_ (dummy_false_) (not_ dummy_false_) -let true_ = not_ (and_ (dummy_true_) (not_ dummy_true_)) - -let is_false_term t = - if (alpha_equal t false_) then true - else false - -let is_true_term t = - if (alpha_equal t true_) then true - else false - -(* Print a term [t] via the [ostream]: *) -let rec fprint_term ostream t prec = - let l_print op_prec = - if (prec > op_prec) then fprintf ostream "(" in - let r_print op_prec = - if (prec > op_prec) then fprintf ostream ")" in - if is_false_term t then (* false *) - fprint_str_list ostream ["False"] - else if is_true_term t then (* true *) - fprint_str_list ostream ["True"] - else if is_all_term t then (* for all *) - let v, t1, t2 = dest_all t in - fprint_str_list ostream ["A."^v]; - fprint_term ostream t2 4 - else if is_exists_term t then (* exists *) - let v, t1, t2 = dest_exists t in - fprint_str_list ostream ["E."^v]; - fprint_term ostream t2 4 (* implication *) - else if is_implies_term t then - let t1, t2 = dest_implies t in - l_print 0; - fprint_term ostream t1 1; - fprint_str_list ostream ["=>"]; - fprint_term ostream t2 0; - r_print 0 - else if is_and_term t then (* logical and *) - let t1, t2 = dest_and t in - l_print 3; - fprint_term ostream t1 3; - fprint_str_list ostream ["&"]; - fprint_term ostream t2 3; - r_print 3 - else if is_or_term t then (* logical or *) - let t1, t2 = dest_or t in - l_print 2; - fprint_term ostream t1 2; - fprint_str_list ostream ["|"]; - fprint_term ostream t2 2; - r_print 2 - else if is_not_term t then (* logical not *) - let t2 = dest_not t in - fprint_str_list ostream ["~"]; - fprint_term ostream t2 4 (* nil term *) - else if is_xnil_term t then - fprint_str_list ostream ["NIL"] - else match t with (* other cases *) - { term_op = { op_name = opname; op_params = opparm }; term_terms = bterms} -> - if (Opname.eq opname pred_opname) || (Opname.eq opname fun_opname) then - begin - fprint_param_list ostream opparm; - if bterms != [] then - begin - fprintf ostream "("; - fprint_bterm_list ostream prec bterms; - fprintf ostream ")"; - end - end else - begin - fprintf ostream "["; -(* fprint_opname ostream opname; - fprintf ostream ": "; *) - fprint_param_list ostream opparm; - if bterms != [] then - begin - fprintf ostream "("; - fprint_bterm_list ostream prec bterms; - fprintf ostream ")"; - end; - fprintf ostream "]" - end -and fprint_bterm_list ostream prec = function - | [] -> () - | {bvars=bv; bterm=bt}::r -> - fprint_str_list ostream bv; - fprint_term ostream bt prec; - if (r<>[]) then fprint_str_list ostream [","]; - fprint_bterm_list ostream prec r -;; - - -let print_term ostream t = - Format.print_flush (); - fprint_term ostream t 0; - Format.print_flush () - -let print_error_msg = function - | RefineError(s,e) -> print_string ("(module "^s^") "); - begin - match e with - | TermMatchError(t,s) -> print_term stdout t; print_string (s^"\n") - | StringError s -> print_string (s^"\n") - end - | ue -> print_string "Unexpected error for Jp.\n"; - raise ue - - -(* Naive implementation for [jterm] substitution, unification, etc.: *) -let substitute subst term = - apply_subst term subst - -(* A naive unification algorithm: *) -let compsubst subst1 subst2 = - (List.map (fun (v, t) -> (v, substitute subst1 t)) subst2) @ subst1 -;; - -let rec extract_terms = function - | [] -> [] - | h::r -> let {bvars=_; bterm=bt}=h in bt::extract_terms r - -(* Occurs check: *) -let occurs v t = - let rec occur_rec t = - if is_var_term t then v=dest_var t - else let { term_op = _ ; term_terms = bterms} = t in - let sons = extract_terms bterms in - List.exists occur_rec sons - in - occur_rec t - -(* The naive unification algorithm: *) -let rec unify2 (term1,term2) = - if is_var_term term1 then - if equal_term [] term1 term2 then [] - else let v1 = dest_var term1 in - if occurs v1 term2 then raise (RefineError ("unify1", StringError ("1"))) - else [v1,term2] - else if is_var_term term2 then - let v2 = dest_var term2 in - if occurs v2 term1 then raise (RefineError ("unify2", StringError ("2"))) - else [v2,term1] - else - let { term_op = { op_name = opname1; op_params = params1 }; - term_terms = bterms1 - } = term1 - in - let { term_op = { op_name = opname2; op_params = params2 }; - term_terms = bterms2 - } = term2 - in - if Opname.eq opname1 opname2 & params1 = params2 then - let sons1 = extract_terms bterms1 - and sons2 = extract_terms bterms2 in - List.fold_left2 - (fun s t1 t2 -> compsubst - (unify2 (substitute s t1, substitute s t2)) s) - [] sons1 sons2 - else raise (RefineError ("unify3", StringError ("3"))) - -let unify term1 term2 = unify2 (term1, term2) -let unify_mm term1 term2 _ = unify2 (term1, term2) diff --git a/contrib/jprover/jterm.mli b/contrib/jprover/jterm.mli deleted file mode 100644 index 0bc42010..00000000 --- a/contrib/jprover/jterm.mli +++ /dev/null @@ -1,110 +0,0 @@ -(* This module is modified and extracted from Meta-Prl. *) - -(* Definitions of [jterm]: *) -type param = param' -and operator = operator' -and term = term' -and bound_term = bound_term' -and param' = - | Number of int - | String of string - | Token of string - | Var of string - | ParamList of param list -and operator' = { op_name : Opname.opname; op_params : param list; } -and term' = { term_op : operator; term_terms : bound_term list; } -and bound_term' = { bvars : string list; bterm : term; } -type term_subst = (string * term) list - -type error_msg = TermMatchError of term * string | StringError of string - -exception RefineError of string * error_msg - -(* Collect free variables: *) -val free_vars_list : term -> string list - -(* Substitutions: *) -val subst_term : term list -> string list list -> string list -> term -> term -val subst : term -> string list -> term list -> term -val subst1 : term -> string -> term -> term -val var_subst : term -> term -> string -> term -val apply_subst : term -> (string * term) list -> term - -(* Unification: *) -val unify_mm : term -> term -> 'a -> (string * term) list - -val xnil_term : term' - -(* Testing functions: *) -val is_xnil_term : term' -> bool -val is_var_term : term' -> bool -val is_true_term : term' -> bool -val is_false_term : term' -> bool -val is_all_term : term' -> bool -val is_exists_term : term' -> bool -val is_or_term : term' -> bool -val is_and_term : term' -> bool -val is_cor_term : term' -> bool -val is_cand_term : term' -> bool -val is_implies_term : term' -> bool -val is_iff_term : term' -> bool -val is_not_term : term' -> bool -val is_fun_term : term -> bool -val is_const_term : term -> bool - - -(* Constructors for [jterms]: *) -val var_ : string -> term' -val fun_ : string -> term list -> term' -val const_ : string -> term' -val pred_ : string -> term list -> term' -val not_ : term -> term' -val and_ : term -> term -> term' -val or_ : term -> term -> term' -val imp_ : term -> term -> term' -val cand_ : term -> term -> term' -val cor_ : term -> term -> term' -val iff_ : term -> term -> term' -val false_ : term' -val true_ : term' -val nil_term : term' -val forall : string -> term -> term' -val exists : string -> term -> term' - - -(* Destructors for [jterm]: *) -val dest_var : term -> string -val dest_fun : term -> string * term list -val dest_const : term -> string -val dest_not : term -> term -val dest_iff : term -> term * term -val dest_implies : term -> term * term -val dest_cand : term -> term * term -val dest_cor : term -> term * term -val dest_and : term -> term * term -val dest_or : term -> term * term -val dest_exists : term -> string * term * term -val dest_all : term -> string * term * term - -(* Wide-logical connectives: *) -val wand_ : term list -> term -val wor_ : term list -> term -val wimp_ : term list -> term - -(* Printing and debugging tools: *) -val fprint_str_list : out_channel -> string list -> unit -val mbreak : string -> unit -val print_strs : string list -> unit -val print_term : out_channel -> term -> unit -val print_error_msg : exn -> unit - -(* Other exported functions for [jall.ml]: *) -val make_term : 'a -> 'a -val dest_term : 'a -> 'a -val make_op : 'a -> 'a -val dest_op : 'a -> 'a -val make_bterm : 'a -> 'a -val dest_bterm : 'a -> 'a -val dest_param : 'a -> 'a -val mk_var_term : string -> term' -val mk_string_term : Opname.opname -> string -> term' diff --git a/contrib/jprover/jtunify.ml b/contrib/jprover/jtunify.ml deleted file mode 100644 index 91aa6b4b..00000000 --- a/contrib/jprover/jtunify.ml +++ /dev/null @@ -1,507 +0,0 @@ -(* - * Unification procedures for JProver. See jall.mli for more - * information on JProver. - * - * ---------------------------------------------------------------- - * - * This file is part of MetaPRL, a modular, higher order - * logical framework that provides a logical programming - * environment for OCaml and other languages. - * - * See the file doc/index.html for information on Nuprl, - * OCaml, and more information about this system. - * - * Copyright (C) 2000 Stephan Schmitt - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - * - * Author: Stephan Schmitt - * Modified by: Aleksey Nogin - *) - -exception Not_unifiable -exception Failed - -let jprover_bug = Invalid_argument "Jprover bug (Jtunify module)" - -(* ************ T-STRING UNIFICATION *********************************) - - -(* ******* printing ********** *) - -let rec list_to_string s = - match s with - [] -> "" - | f::r -> - f^"."^(list_to_string r) - -let rec print_eqlist eqlist = - match eqlist with - [] -> - print_endline "" - | (atnames,f)::r -> - let (s,t) = f in - let ls = list_to_string s - and lt = list_to_string t in - begin - print_endline ("Atom names: "^(list_to_string atnames)); - print_endline (ls^" = "^lt); - print_eqlist r - end - -let print_equations eqlist = - begin - Format.open_box 0; - Format.force_newline (); - print_endline "Equations:"; - print_eqlist eqlist; - Format.force_newline (); - end - -let rec print_subst sigma = - match sigma with - [] -> - print_endline "" - | f::r -> - let (v,s) = f in - let ls = list_to_string s in - begin - print_endline (v^" = "^ls); - print_subst r - end - -let print_tunify sigma = - let (n,subst) = sigma in - begin - print_endline " "; - print_endline ("MaxVar = "^(string_of_int (n-1))); - print_endline " "; - print_endline "Substitution:"; - print_subst subst; - print_endline " " - end - - (*****************************************************) - -let is_const name = - (String.get name 0) = 'c' - -let is_var name = - (String.get name 0) = 'v' - -let r_1 s ft rt = - (s = []) && (ft = []) && (rt = []) - -let r_2 s ft rt = - (s = []) && (ft = []) && (List.length rt >= 1) - -let r_3 s ft rt = - ft=[] && (List.length s >= 1) && (List.length rt >= 1) && (List.hd s = List.hd rt) - -let r_4 s ft rt = - ft=[] - && (List.length s >= 1) - && (List.length rt >= 1) - && is_const (List.hd s) - && is_var (List.hd rt) - -let r_5 s ft rt = - rt=[] - && (List.length s >= 1) - && is_var (List.hd s) - -let r_6 s ft rt = - ft=[] - && (List.length s >= 1) - && (List.length rt >= 1) - && is_var (List.hd s) - && is_const (List.hd rt) - -let r_7 s ft rt = - List.length s >= 1 - && (List.length rt >= 2) - && is_var (List.hd s) - && is_const (List.hd rt) - && is_const (List.hd (List.tl rt)) - -let r_8 s ft rt = - ft=[] - && List.length s >= 2 - && List.length rt >= 1 - && let v = List.hd s - and v1 = List.hd rt in - (is_var v) & (is_var v1) & (v <> v1) - -let r_9 s ft rt = - (List.length s >= 2) && (List.length ft >= 1) && (List.length rt >= 1) - && let v = (List.hd s) - and v1 = (List.hd rt) in - (is_var v) & (is_var v1) & (v <> v1) - -let r_10 s ft rt = - (List.length s >= 1) && (List.length rt >= 1) - && let v = List.hd s - and x = List.hd rt in - (is_var v) && (v <> x) - && (((List.tl s) =[]) or (is_const x) or ((List.tl rt) <> [])) - -let rec com_subst slist ((ov,ovlist) as one_subst) = - match slist with - [] -> raise jprover_bug - | f::r -> - if f = ov then - (ovlist @ r) - else - f::(com_subst r one_subst) - -let rec combine subst ((ov,oslist) as one_subst) = - match subst with - [] -> [] - | ((v, slist) as f) :: r -> - let rest_combine = (combine r one_subst) in - if (List.mem ov slist) then (* subst assumed to be idemponent *) - let com_element = com_subst slist one_subst in - ((v,com_element)::rest_combine) - else - (f::rest_combine) - -let compose ((n,subst) as _sigma) ((ov,oslist) as one_subst) = - let com = combine subst one_subst in -(* begin - print_endline "!!!!!!!!!test print!!!!!!!!!!"; - print_subst [one_subst]; - print_subst subst; - print_endline "!!!!!!!!! END test print!!!!!!!!!!"; -*) - if List.mem one_subst subst then - (n,com) - else -(* ov may multiply as variable in subst with DIFFERENT values *) -(* in order to avoid explicit atom instances!!! *) - (n,(com @ [one_subst])) -(* end *) - -let rec apply_element fs ft (v,slist) = - match (fs,ft) with - ([],[]) -> - ([],[]) - | ([],(ft_first::ft_rest)) -> - let new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in - (emptylist,(new_ft_first @ new_ft_rest)) - | ((fs_first::fs_rest),[]) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - in - let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in - ((new_fs_first @ new_fs_rest),emptylist) - | ((fs_first::fs_rest),(ft_first::ft_rest)) -> - let new_fs_first = - if fs_first = v then - slist - else - [fs_first] - and new_ft_first = - if ft_first = v then - slist - else - [ft_first] - in - let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in - ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest)) - -let rec shorten us ut = - match (us,ut) with - ([],_) | (_,[]) -> (us,ut) (*raise jprover_bug*) - | ((fs::rs),(ft::rt)) -> - if fs = ft then - shorten rs rt - else - (us,ut) - -let rec apply_subst_list eq_rest (v,slist) = - match eq_rest with - [] -> - (true,[]) - | (atomnames,(fs,ft))::r -> - let (n_fs,n_ft) = apply_element fs ft (v,slist) in - let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *) - match (new_fs,new_ft) with - [],[] -> - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],[]))::new_eq_rest)) - | [],(fft::rft) -> - if (is_const fft) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,([],new_ft))::new_eq_rest)) - | (ffs::rfs),[] -> - if (is_const ffs) then - (false,[]) - else - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,[]))::new_eq_rest)) - | (ffs::rfs),(fft::rft) -> - if (is_const ffs) & (is_const fft) then - (false,[]) - (* different first constants cause local fail *) - else - (* at least one of firsts is a variable *) - let (bool,new_eq_rest) = apply_subst_list r (v,slist) in - (bool,((atomnames,(new_fs,new_ft))::new_eq_rest)) - -let apply_subst eq_rest (v,slist) atomnames = - if (List.mem v atomnames) then (* don't apply subst to atom variables !! *) - (true,eq_rest) - else - apply_subst_list eq_rest (v,slist) - - -(* let all_variable_check eqlist = false needs some discussion with Jens! -- NOT done *) - -(* - let rec all_variable_check eqlist = - match eqlist with - [] -> true - | ((_,(fs,ft))::rest_eq) -> - if (fs <> []) & (ft <> []) then - let fs_first = List.hd fs - and ft_first = List.hd ft - in - if (is_const fs_first) or (is_const ft_first) then - false - else - all_variable_check rest_eq - else - false -*) - -let rec tunify_list eqlist init_sigma = - let rec tunify atomnames fs ft rt rest_eq sigma = - let apply_r1 fs ft rt rest_eq sigma = - (* print_endline "r1"; *) - tunify_list rest_eq sigma - - in - let apply_r2 fs ft rt rest_eq sigma = - (* print_endline "r2"; *) - tunify atomnames rt fs ft rest_eq sigma - - in - let apply_r3 fs ft rt rest_eq sigma = - (* print_endline "r3"; *) - let rfs = (List.tl fs) - and rft = (List.tl rt) in - tunify atomnames rfs ft rft rest_eq sigma - - in - let apply_r4 fs ft rt rest_eq sigma = - (* print_endline "r4"; *) - tunify atomnames rt ft fs rest_eq sigma - - in - let apply_r5 fs ft rt rest_eq sigma = - (* print_endline "r5"; *) - let v = (List.hd fs) in - let new_sigma = compose sigma (v,ft) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in - if (bool=false) then - raise Not_unifiable - else - tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma - - in - let apply_r6 fs ft rt rest_eq sigma = - (* print_endline "r6"; *) - let v = (List.hd fs) in - let new_sigma = (compose sigma (v,[])) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in - if (bool=false) then - raise Not_unifiable - else - tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma - - in - let apply_r7 fs ft rt rest_eq sigma = - (* print_endline "r7"; *) - let v = (List.hd fs) - and c1 = (List.hd rt) - and c2t =(List.tl rt) in - let new_sigma = (compose sigma (v,(ft @ [c1]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in - if bool=false then - raise Not_unifiable - else - tunify atomnames (List.tl fs) [] c2t new_rest_eq new_sigma - in - let apply_r8 fs ft rt rest_eq sigma = - (* print_endline "r8"; *) - tunify atomnames rt [(List.hd fs)] (List.tl fs) rest_eq sigma - - in - let apply_r9 fs ft rt rest_eq sigma = - (* print_endline "r9"; *) - let v = (List.hd fs) - and (max,subst) = sigma in - let v_new = ("vnew"^(string_of_int max)) in - let new_sigma = (compose ((max+1),subst) (v,(ft @ [v_new]))) in - let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in - if (bool=false) then - raise Not_unifiable - else - tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma - - in - let apply_r10 fs ft rt rest_eq sigma = - (* print_endline "r10"; *) - let x = List.hd rt in - tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma - - in - if r_1 fs ft rt then - apply_r1 fs ft rt rest_eq sigma - else if r_2 fs ft rt then - apply_r2 fs ft rt rest_eq sigma - else if r_3 fs ft rt then - apply_r3 fs ft rt rest_eq sigma - else if r_4 fs ft rt then - apply_r4 fs ft rt rest_eq sigma - else if r_5 fs ft rt then - apply_r5 fs ft rt rest_eq sigma - else if r_6 fs ft rt then - (try - apply_r6 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *) - ) - else - (* r10 could be represented only once if we would try it before r7.*) - (* but looking at the transformation rules, r10 should be tried at last in any case *) - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable r6 was *) - ) - else if r_7 fs ft rt then (* not r6 and r7 possible if z <> [] *) - (try - apply_r7 fs ft rt rest_eq sigma - with Not_unifiable -> - apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r7 was *) - ) - else if r_8 fs ft rt then - (try - apply_r8 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - else if r_9 fs ft rt then - (try - apply_r9 fs ft rt rest_eq sigma - with Not_unifiable -> - if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *) - apply_r10 fs ft rt rest_eq sigma - else - raise Not_unifiable (* simply back propagation *) - ) - else if r_10 fs ft rt then (* not ri, i<10, and r10 possible if for instance *) - (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *) - apply_r10 fs ft rt rest_eq sigma - else (* NO rule applicable *) - raise Not_unifiable - in - match eqlist with - [] -> - init_sigma - | f::rest_eq -> - let (atomnames,(fs,ft)) = f in - tunify atomnames fs [] ft rest_eq init_sigma - -let rec test_apply_eq atomnames eqs eqt subst = - match subst with - [] -> (eqs,eqt) - | (f,flist)::r -> - let (first_appl_eqs,first_appl_eqt) = - if List.mem f atomnames then - (eqs,eqt) - else - (apply_element eqs eqt (f,flist)) - in - test_apply_eq atomnames first_appl_eqs first_appl_eqt r - -let rec test_apply_eqsubst eqlist subst = - match eqlist with - [] -> [] - | f::r -> - let (atomnames,(eqs,eqt)) = f in - let applied_element = test_apply_eq atomnames eqs eqt subst in - (atomnames,applied_element)::(test_apply_eqsubst r subst) - -let ttest us ut ns nt eqlist orderingQ atom_rel = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *) - (* to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element eqlist then - eqlist - else - new_element::eqlist - in - let sigma = tunify_list full_eqlist (1,[]) in - let (n,subst) = sigma in - let test_apply = test_apply_eqsubst full_eqlist subst in - begin - print_endline ""; - print_endline "Final equations:"; - print_equations full_eqlist; - print_endline ""; - print_endline "Final substitution:"; - print_tunify sigma; - print_endline ""; - print_endline "Applied equations:"; - print_equations test_apply - end - -let do_stringunify us ut ns nt equations = - let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *) - let new_element = ([ns;nt],(short_us,short_ut)) in - let full_eqlist = - if List.mem new_element equations then - equations - else - new_element::equations - in -(* print_equations full_eqlist; *) - (try - let new_sigma = tunify_list full_eqlist (1,[]) in - (new_sigma,(1,full_eqlist)) - with Not_unifiable -> - raise Failed (* new connection please *) - ) - - -(* type of one unifier: int * (string * string) list *) diff --git a/contrib/jprover/jtunify.mli b/contrib/jprover/jtunify.mli deleted file mode 100644 index 0aabc79e..00000000 --- a/contrib/jprover/jtunify.mli +++ /dev/null @@ -1,35 +0,0 @@ -exception Not_unifiable -exception Failed - -(* Utilities *) - -val is_const : string -> bool -val is_var : string -> bool -val r_1 : 'a list -> 'b list -> 'c list -> bool -val r_2 : 'a list -> 'b list -> 'c list -> bool -val r_3 : 'a list -> 'b list -> 'a list -> bool -val r_4 : string list -> 'a list -> string list -> bool -val r_5 : string list -> 'a -> 'b list -> bool -val r_6 : string list -> 'a list -> string list -> bool -val r_7 : string list -> 'a -> string list -> bool -val r_8 : string list -> 'a list -> string list -> bool -val r_9 : string list -> 'a list -> string list -> bool -val r_10 : string list -> 'a -> string list -> bool -val com_subst : 'a list -> 'a * 'a list -> 'a list - -(* Debugging *) - -val print_equations : (string list * (string list * string list)) list -> unit - -val print_tunify : int * (string * string list) list -> unit - -(* Main function *) - -val do_stringunify : string list -> - string list -> - string -> - string -> - (string list * (string list * string list)) list -> - (int * (string * string list) list) * (* unifier *) - (int * ((string list * (string list * string list)) list)) (* applied new eqlist *) - diff --git a/contrib/jprover/opname.ml b/contrib/jprover/opname.ml deleted file mode 100644 index d0aa9046..00000000 --- a/contrib/jprover/opname.ml +++ /dev/null @@ -1,90 +0,0 @@ -open Printf - -type token = string -type atom = string list - -let opname_token = String.make 4 (Char.chr 0) - -type opname = - { mutable opname_token : token; - mutable opname_name : string list - } - -let (optable : (string list, opname) Hashtbl.t) = Hashtbl.create 97 - -(* * Constructors.*) -let nil_opname = { opname_token = opname_token; opname_name = [] } - -let _ = Hashtbl.add optable [] nil_opname - -let rec mk_opname s ({ opname_token = token; opname_name = name } as opname) = - if token == opname_token then - let name = s :: name in - try Hashtbl.find optable name with - Not_found -> - let op = { opname_token = opname_token; opname_name = name } in - Hashtbl.add optable name op; - op - else - mk_opname s (normalize_opname opname) - -and make_opname = function - | [] -> - nil_opname - | h :: t -> - mk_opname h (make_opname t) - -and normalize_opname opname = - if opname.opname_token == opname_token then - (* This opname is already normalized *) - opname - else - let res = make_opname opname.opname_name - in - opname.opname_name <- res.opname_name; - opname.opname_token <- opname_token; - res - -(* * Atoms are the inner string list. *) -let intern opname = - if opname.opname_token == opname_token then - opname.opname_name - else - let name = (normalize_opname opname).opname_name in - opname.opname_token <- opname_token; - opname.opname_name <- name; - name - -let eq_inner op1 op2 = - op1.opname_name <- (normalize_opname op1).opname_name; - op1.opname_token <- opname_token; - op2.opname_name <- (normalize_opname op2).opname_name; - op2.opname_token <- opname_token; - op1.opname_name == op2.opname_name - -let eq op1 op2 = - (op1.opname_name == op2.opname_name) - or ((op1.opname_token != opname_token or op2.opname_token != opname_token) & eq_inner op1 op2) - -(* * Destructor. *) -let dst_opname = function - | { opname_name = n :: name } -> n, { opname_token = opname_token; opname_name = name } - | _ -> raise (Invalid_argument "dst_opname") - -let dest_opname { opname_name = name } = - name - -let string_of_opname op = - let rec flatten = function - | [] -> - "" - | h::t -> - let rec collect s = function - | h::t -> - collect (h ^ "!" ^ s) t - | [] -> - s - in - collect h t - in - flatten op.opname_name diff --git a/contrib/jprover/opname.mli b/contrib/jprover/opname.mli deleted file mode 100644 index 56bf84e2..00000000 --- a/contrib/jprover/opname.mli +++ /dev/null @@ -1,15 +0,0 @@ -(* This module is extracted from Meta-Prl. *) - -type token = string -and atom = string list -val opname_token : token -type opname = { - mutable opname_token : token; - mutable opname_name : string list; -} -val nil_opname : opname -val mk_opname : string -> opname -> opname -val make_opname : string list -> opname -val eq : opname -> opname -> bool -val dest_opname : opname -> string list -val string_of_opname : opname -> string diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml index 5ae12394..b4863ffc 100644 --- a/contrib/micromega/coq_micromega.ml +++ b/contrib/micromega/coq_micromega.ml @@ -1193,7 +1193,7 @@ let call_csdpcert provername poly = output_value ch_to (provername,poly : provername * micromega_polys); close_out ch_to; let cmdname = - List.fold_left Filename.concat Coq_config.coqlib + List.fold_left Filename.concat (Envars.coqlib ()) ["contrib"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in (try Sys.remove tmp_to with _ -> ()); diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v index ae642a3e..5c240553 100644 --- a/contrib/omega/OmegaLemmas.v +++ b/contrib/omega/OmegaLemmas.v @@ -6,12 +6,51 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id: OmegaLemmas.v 7727 2005-12-25 13:42:20Z herbelin $ i*) +(*i $Id: OmegaLemmas.v 11739 2009-01-02 19:33:19Z herbelin $ i*) Require Import ZArith_base. Open Local Scope Z_scope. -(** These are specific variants of theorems dedicated for the Omega tactic *) +(** Factorization lemmas *) + +Theorem Zred_factor0 : forall n:Z, n = n * 1. + intro x; rewrite (Zmult_1_r x); reflexivity. +Qed. + +Theorem Zred_factor1 : forall n:Z, n + n = n * 2. +Proof. + exact Zplus_diag_eq_mult_2. +Qed. + +Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m). +Proof. + intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x); + rewrite <- Zmult_plus_distr_r; trivial with arith. +Qed. + +Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). +Proof. + intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); + rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; + trivial with arith. +Qed. + +Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p). +Proof. + intros x y z; symmetry in |- *; apply Zmult_plus_distr_r. +Qed. + +Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m. +Proof. + intros x y; rewrite <- Zmult_0_r_reverse; auto with arith. +Qed. + +Theorem Zred_factor6 : forall n:Z, n = n + 0. +Proof. + intro; rewrite Zplus_0_r; trivial with arith. +Qed. + +(** Other specific variants of theorems dedicated for the Omega tactic *) Lemma new_var : forall x : Z, exists y : Z, x = y. intros x; exists x; trivial with arith. diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index 84092812..58873c2d 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id: coq_omega.ml 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: coq_omega.ml 11735 2009-01-02 17:22:31Z herbelin $ *) open Util open Pp @@ -309,6 +309,7 @@ let coq_dec_True = lazy (constant "dec_True") let coq_not_or = lazy (constant "not_or") let coq_not_and = lazy (constant "not_and") let coq_not_imp = lazy (constant "not_imp") +let coq_not_iff = lazy (constant "not_iff") let coq_not_not = lazy (constant "not_not") let coq_imp_simp = lazy (constant "imp_simp") let coq_iff = lazy (constant "iff") @@ -362,7 +363,7 @@ type omega_constant = | Eq | Neq | Zne | Zle | Zlt | Zge | Zgt | Z | Nat - | And | Or | False | True | Not + | And | Or | False | True | Not | Iff | Le | Lt | Ge | Gt | Other of string @@ -388,8 +389,7 @@ let destructurate_prop t = | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args) | _, [_;_] when c = build_coq_and () -> Kapp (And,args) | _, [_;_] when c = build_coq_or () -> Kapp (Or,args) - | _, [t1;t2] when c = Lazy.force coq_iff -> - Kapp (And,[mkArrow t1 t2;mkArrow t2 t1]) + | _, [_;_] when c = Lazy.force coq_iff -> Kapp (Iff, args) | _, [_] when c = build_coq_not () -> Kapp (Not,args) | _, [] when c = build_coq_False () -> Kapp (False,args) | _, [] when c = build_coq_True () -> Kapp (True,args) @@ -1557,6 +1557,9 @@ let rec decidability gl t = | Kapp(And,[t1;t2]) -> mkApp (Lazy.force coq_dec_and, [| t1; t2; decidability gl t1; decidability gl t2 |]) + | Kapp(Iff,[t1;t2]) -> + mkApp (Lazy.force coq_dec_iff, [| t1; t2; + decidability gl t1; decidability gl t2 |]) | Kimp(t1,t2) -> mkApp (Lazy.force coq_dec_imp, [| t1; t2; decidability gl t1; decidability gl t2 |]) @@ -1620,6 +1623,30 @@ let destructure_hyps gl = (introduction i2); (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl) ] + | Kapp(Iff,[t1;t2]) -> + tclTHENLIST [ + (elim_id i); + (tclTRY (clear [i])); + (fun gl -> + let i1 = fresh_id [] (add_suffix i "_left") gl in + let i2 = fresh_id [] (add_suffix i "_right") gl in + tclTHENLIST [ + introduction i1; + generalize_tac + [mkApp (Lazy.force coq_imp_simp, + [| t1; t2; decidability gl t1; mkVar i1|])]; + onClearedName i1 (fun i1 -> + tclTHENLIST [ + introduction i2; + generalize_tac + [mkApp (Lazy.force coq_imp_simp, + [| t2; t1; decidability gl t2; mkVar i2|])]; + onClearedName i2 (fun i2 -> + loop + ((i1,None,mk_or (mk_not t1) t2):: + (i2,None,mk_or (mk_not t2) t1)::lit)) + ])] gl) + ] | Kimp(t1,t2) -> if is_Prop (pf_type_of gl t1) & @@ -1647,10 +1674,20 @@ let destructure_hyps gl = tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_and, [| t1; t2; - decidability gl t1;mkVar i|])]); + decidability gl t1; mkVar i|])]); (onClearedName i (fun i -> (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) ] + | Kapp(Iff,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_iff, [| t1; t2; + decidability gl t1; decidability gl t2; mkVar i|])]); + (onClearedName i (fun i -> + (loop ((i,None, + mk_or (mk_and t1 (mk_not t2)) + (mk_and (mk_not t1) t2))::lit)))) + ] | Kimp(t1,t2) -> tclTHENLIST [ (generalize_tac diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index 3d13a254..f2706307 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ring.ml 11094 2008-06-10 19:35:23Z herbelin $ *) +(* $Id: ring.ml 11800 2009-01-18 18:34:15Z msozeau $ *) (* ML part of the Ring tactic *) @@ -307,14 +307,14 @@ let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false let implement_theory env t th args = is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args)) -(* The following test checks whether the provided morphism is the default - one for the given operation. In principle the test is too strict, since - it should possible to provide another proof for the same fact (proof - irrelevance). In particular, the error message is be not very explicative. *) +(* (\* The following test checks whether the provided morphism is the default *) +(* one for the given operation. In principle the test is too strict, since *) +(* it should possible to provide another proof for the same fact (proof *) +(* irrelevance). In particular, the error message is be not very explicative. *\) *) let states_compatibility_for env plus mult opp morphs = - let check op compat = - is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem - compat in + let check op compat = true in +(* is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *) +(* compat in *) check plus morphs.plusm && check mult morphs.multm && (match (opp,morphs.oppm) with @@ -826,12 +826,10 @@ let raw_polynom th op lc gl = c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (tclORELSE - (Setoid_replace.general_s_rewrite true - Termops.all_occurrences c'i_eq_c''i - ~new_goals:[]) - (Setoid_replace.general_s_rewrite false - Termops.all_occurrences c'i_eq_c''i - ~new_goals:[])) + (Equality.general_rewrite true + Termops.all_occurrences c'i_eq_c''i) + (Equality.general_rewrite false + Termops.all_occurrences c'i_eq_c''i)) [tac])) else (tclORELSE @@ -881,7 +879,7 @@ let guess_equiv_tac th = let match_with_equiv c = match (kind_of_term c) with | App (e,a) -> - if (List.mem e (Setoid_replace.equiv_list ())) + if (List.mem e []) (* (Setoid_replace.equiv_list ())) *) then Some (decompose_app c) else None | _ -> None diff --git a/contrib/setoid_ring/Ring_base.v b/contrib/setoid_ring/Ring_base.v index 95b037e3..956a15fe 100644 --- a/contrib/setoid_ring/Ring_base.v +++ b/contrib/setoid_ring/Ring_base.v @@ -10,7 +10,6 @@ ring tactic. Abstract rings need more theory, depending on ZArith_base. *) -Declare ML Module "newring". Require Export Ring_theory. Require Export Ring_tac. Require Import InitialRing. diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v index 46d106d3..ad20fa08 100644 --- a/contrib/setoid_ring/Ring_tac.v +++ b/contrib/setoid_ring/Ring_tac.v @@ -4,7 +4,6 @@ Require Import BinPos. Require Import Ring_polynom. Require Import BinList. Require Import InitialRing. -Declare ML Module "newring". (* adds a definition id' on the normal form of t and an hypothesis id diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 index 3d022add..50b7e47b 100644 --- a/contrib/setoid_ring/newring.ml4 +++ b/contrib/setoid_ring/newring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: newring.ml4 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: newring.ml4 11800 2009-01-18 18:34:15Z msozeau $ i*) open Pp open Util @@ -19,12 +19,12 @@ open Environ open Libnames open Tactics open Rawterm +open Termops open Tacticals open Tacexpr open Pcoq open Tactic open Constr -open Setoid_replace open Proof_type open Coqlib open Tacmach @@ -452,12 +452,13 @@ let (theory_to_obj, obj_to_theory) = let setoid_of_relation env a r = + let evm = Evd.empty in try lapp coq_mk_Setoid [|a ; r ; - Class_tactics.reflexive_proof env a r ; - Class_tactics.symmetric_proof env a r ; - Class_tactics.transitive_proof env a r |] + Class_tactics.get_reflexive_proof env evm a r ; + Class_tactics.get_symmetric_proof env evm a r ; + Class_tactics.get_transitive_proof env evm a r |] with Not_found -> error "cannot find setoid relation" diff --git a/contrib/subtac/equations.ml4 b/contrib/subtac/equations.ml4 new file mode 100644 index 00000000..9d120019 --- /dev/null +++ b/contrib/subtac/equations.ml4 @@ -0,0 +1,1149 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mkRel i + | PCstr (c, p) -> + let c' = mkConstruct c in + mkApp (c', Array.of_list (constrs_of_pats ~inacc env p)) + | PInac r -> + if inacc then try mkInac env r with _ -> r else r + +and constrs_of_pats ?(inacc=true) env l = map (constr_of_pat ~inacc env) l + +let rec pat_vars = function + | PRel i -> Intset.singleton i + | PCstr (c, p) -> pats_vars p + | PInac _ -> Intset.empty + +and pats_vars l = + fold_left (fun vars p -> + let pvars = pat_vars p in + let inter = Intset.inter pvars vars in + if inter = Intset.empty then + Intset.union pvars vars + else error ("Non-linear pattern: variable " ^ + string_of_int (Intset.choose inter) ^ " appears twice")) + Intset.empty l + +let rec pats_of_constrs l = map pat_of_constr l +and pat_of_constr c = + match kind_of_term c with + | Rel i -> PRel i + | App (f, [| a ; c |]) when eq_constr f (Lazy.force coq_inacc) -> + PInac c + | App (f, args) when isConstruct f -> + PCstr (destConstruct f, pats_of_constrs (Array.to_list args)) + | Construct f -> PCstr (f, []) + | _ -> PInac c + +let inaccs_of_constrs l = map (fun x -> PInac x) l + +exception Conflict + +let rec pmatch p c = + match p, c with + | PRel i, t -> [i, t] + | PCstr (c, pl), PCstr (c', pl') when c = c' -> pmatches pl pl' + | PInac _, _ -> [] + | _, PInac _ -> [] + | _, _ -> raise Conflict + +and pmatches pl l = + match pl, l with + | [], [] -> [] + | hd :: tl, hd' :: tl' -> + pmatch hd hd' @ pmatches tl tl' + | _ -> raise Conflict + +let pattern_matches pl l = try Some (pmatches pl l) with Conflict -> None + +let rec pinclude p c = + match p, c with + | PRel i, t -> true + | PCstr (c, pl), PCstr (c', pl') when c = c' -> pincludes pl pl' + | PInac _, _ -> true + | _, PInac _ -> true + | _, _ -> false + +and pincludes pl l = + match pl, l with + | [], [] -> true + | hd :: tl, hd' :: tl' -> + pinclude hd hd' && pincludes tl tl' + | _ -> false + +let pattern_includes pl l = pincludes pl l + +(** Specialize by a substitution. *) + +let subst_tele s = replace_vars (List.map (fun (id, _, t) -> id, t) s) + +let subst_rel_subst k s c = + let rec aux depth c = + match kind_of_term c with + | Rel n -> + let k = n - depth in + if k >= 0 then + try lift depth (snd (assoc k s)) + with Not_found -> c + else c + | _ -> map_constr_with_binders succ aux depth c + in aux k c + +let subst_context s ctx = + let (_, ctx') = fold_right + (fun (id, b, t) (k, ctx') -> + (succ k, (id, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx')) + ctx (0, []) + in ctx' + +let subst_rel_context k cstr ctx = + let (_, ctx') = fold_right + (fun (id, b, t) (k, ctx') -> + (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) + ctx (k, []) + in ctx' + +let rec lift_pat n k p = + match p with + | PRel i -> + if i >= k then PRel (i + n) + else p + | PCstr(c, pl) -> PCstr (c, lift_pats n k pl) + | PInac r -> PInac (liftn n k r) + +and lift_pats n k = map (lift_pat n k) + +let rec subst_pat env k t p = + match p with + | PRel i -> + if i = k then t + else if i > k then PRel (pred i) + else p + | PCstr(c, pl) -> + PCstr (c, subst_pats env k t pl) + | PInac r -> PInac (substnl [constr_of_pat ~inacc:false env t] (pred k) r) + +and subst_pats env k t = map (subst_pat env k t) + +let rec specialize s p = + match p with + | PRel i -> + if mem_assoc i s then + let b, t = assoc i s in + if b then PInac t + else PRel (destRel t) + else p + | PCstr(c, pl) -> + PCstr (c, specialize_pats s pl) + | PInac r -> PInac (specialize_constr s r) + +and specialize_constr s c = subst_rel_subst 0 s c +and specialize_pats s = map (specialize s) + +let specialize_patterns = function + | [] -> fun p -> p + | s -> specialize_pats s + +let specialize_rel_context s ctx = + snd (fold_right (fun (n, b, t) (k, ctx) -> + (succ k, (n, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx)) + ctx (0, [])) + +let lift_contextn n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (rel_context_length sign + k) sign + +type program = + signature * clause list + +and signature = identifier * rel_context * constr + +and clause = lhs * (constr, int) rhs + +and lhs = rel_context * identifier * pat list + +and ('a, 'b) rhs = + | Program of 'a + | Empty of 'b + +type splitting = + | Compute of clause + | Split of lhs * int * inductive_family * + unification_result array * splitting option array + +and unification_result = + rel_context * int * constr * pat * substitution option + +and substitution = (int * (bool * constr)) list + +type problem = identifier * lhs + +let rels_of_tele tele = rel_list 0 (List.length tele) + +let patvars_of_tele tele = map (fun c -> PRel (destRel c)) (rels_of_tele tele) + +let split_solves split prob = + match split with + | Compute (lhs, rhs) -> lhs = prob + | Split (lhs, id, indf, us, ls) -> lhs = prob + +let ids_of_constr c = + let rec aux vars c = + match kind_of_term c with + | Var id -> Idset.add id vars + | _ -> fold_constr aux vars c + in aux Idset.empty c + +let ids_of_constrs = + fold_left (fun acc x -> Idset.union (ids_of_constr x) acc) Idset.empty + +let idset_of_list = + fold_left (fun s x -> Idset.add x s) Idset.empty + +let intset_of_list = + fold_left (fun s x -> Intset.add x s) Intset.empty + +let solves split (delta, id, pats as prob) = + split_solves split prob && + Intset.equal (pats_vars pats) (intset_of_list (map destRel (rels_of_tele delta))) + +let check_judgment ctx c t = + ignore(Typing.check (push_rel_context ctx (Global.env ())) Evd.empty c t); true + +let check_context env ctx = + fold_right + (fun (_, _, t as decl) env -> + ignore(Typing.sort_of env Evd.empty t); push_rel decl env) + ctx env + +let split_context n c = + let after, before = list_chop n c in + match before with + | hd :: tl -> after, hd, tl + | [] -> raise (Invalid_argument "split_context") + +let split_tele n (ctx : rel_context) = + let rec aux after n l = + match n, l with + | 0, decl :: before -> before, decl, List.rev after + | n, decl :: before -> aux (decl :: after) (pred n) before + | _ -> raise (Invalid_argument "split_tele") + in aux [] n ctx + +let rec add_var_subst env subst n c = + if mem_assoc n subst then + let t = assoc n subst in + if eq_constr t c then subst + else unify env subst t c + else + let rel = mkRel n in + if rel = c then subst + else if dependent rel c then raise Conflict + else (n, c) :: subst + +and unify env subst x y = + match kind_of_term x, kind_of_term y with + | Rel n, _ -> add_var_subst env subst n y + | _, Rel n -> add_var_subst env subst n x + | App (c, l), App (c', l') when eq_constr c c' -> + unify_constrs env subst (Array.to_list l) (Array.to_list l') + | _, _ -> if eq_constr x y then subst else raise Conflict + +and unify_constrs (env : env) subst l l' = + if List.length l = List.length l' then + fold_left2 (unify env) subst l l' + else raise Conflict + +let fold_rel_context_with_binders f ctx init = + snd (List.fold_right (fun decl (depth, acc) -> + (succ depth, f depth decl acc)) ctx (0, init)) + +let dependent_rel_context (ctx : rel_context) k = + fold_rel_context_with_binders + (fun depth (n,b,t) acc -> + let r = mkRel (depth + k) in + acc || dependent r t || + (match b with + | Some b -> dependent r b + | None -> false)) + ctx false + +let liftn_between n k p c = + let rec aux depth c = match kind_of_term c with + | Rel i -> + if i <= depth then c + else if i-depth > p then c + else mkRel (i - n) + | _ -> map_constr_with_binders succ aux depth c + in aux k c + +let liftn_rel_context n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (k + rel_context_length sign) sign + +let substnl_rel_context n l = + map_rel_context_with_binders (fun k -> substnl l (n+k-1)) + +let reduce_rel_context (ctx : rel_context) (subst : (int * (bool * constr)) list) = + let _, s, ctx' = + fold_left (fun (k, s, ctx') (n, b, t as decl) -> + match b with + | None -> (succ k, mkRel k :: s, ctx' @ [decl]) + | Some t -> (k, lift (pred k) t :: map (substnl [t] (pred k)) s, subst_rel_context 0 t ctx')) + (1, [], []) ctx + in + let s = rev s in + let s' = map (fun (korig, (b, knew)) -> korig, (b, substl s knew)) subst in + s', ctx' + +(* Compute the transitive closure of the dependency relation for a term in a context *) + +let rec dependencies_of_rel ctx k = + let (n,b,t) = nth ctx (pred k) in + let b = Option.map (lift k) b and t = lift k t in + let bdeps = match b with Some b -> dependencies_of_term ctx b | None -> Intset.empty in + Intset.union (Intset.singleton k) (Intset.union bdeps (dependencies_of_term ctx t)) + +and dependencies_of_term ctx t = + let rels = free_rels t in + Intset.fold (fun i -> Intset.union (dependencies_of_rel ctx i)) rels Intset.empty + +let subst_telescope k cstr ctx = + let (_, ctx') = fold_left + (fun (k, ctx') (id, b, t) -> + (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) + (k, []) ctx + in rev ctx' + +let lift_telescope n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (succ k) sign) + | [] -> [] + in liftrec k sign + +type ('a,'b) either = Inl of 'a | Inr of 'b + +let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (int * (int, int) either) list = + let rels = dependencies_of_term ctx t in + let len = length ctx in + let nbdeps = Intset.cardinal rels in + let lifting = len - nbdeps in (* Number of variables not linked to t *) + let rec aux k n acc m rest s = function + | decl :: ctx' -> + if Intset.mem k rels then + let rest' = subst_telescope 0 (mkRel (nbdeps + lifting - pred m)) rest in + aux (succ k) (succ n) (decl :: acc) m rest' ((k, Inl n) :: s) ctx' + else aux (succ k) n (subst_telescope 0 mkProp acc) (succ m) (decl :: rest) ((k, Inr m) :: s) ctx' + | [] -> rev acc, rev rest, s + in aux 1 1 [] 1 [] [] ctx + +let merge_subst (ctx', rest, s) = + let lenrest = length rest in + map (function (k, Inl x) -> (k, (false, mkRel (x + lenrest))) | (k, Inr x) -> k, (false, mkRel x)) s + +(* let simplify_subst s = *) +(* fold_left (fun s (k, t) -> *) +(* match kind_of_term t with *) +(* | Rel n when n = k -> s *) +(* | _ -> (k, t) :: s) *) +(* [] s *) + +let compose_subst s' s = + map (fun (k, (b, t)) -> (k, (b, specialize_constr s' t))) s + +let substitute_in_ctx n c ctx = + let rec aux k after = function + | [] -> [] + | (name, b, t as decl) :: before -> + if k = n then rev after @ (name, Some c, t) :: before + else aux (succ k) (decl :: after) before + in aux 1 [] ctx + +let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) list) (cursubst : (int * (bool * constr)) list) = + match cursubst with + | [] -> ctx, substacc + | (k, (b, t)) :: rest -> + if t = mkRel k then reduce_subst ctx substacc rest + else if noccur_between 1 k t then + (* The term to substitute refers only to previous variables. *) + let t' = lift (-k) t in + let ctx' = substitute_in_ctx k t' ctx in + reduce_subst ctx' substacc rest + else (* The term refers to variables declared after [k], so we have + to move these dependencies before [k]. *) + let (minctx, ctxrest, subst as str) = strengthen ctx t in + match assoc k subst with + | Inl _ -> error "Occurs check in substituted_context" + | Inr k' -> + let s = merge_subst str in + let ctx' = ctxrest @ minctx in + let rest' = + let substsubst (k', (b, t')) = + match kind_of_term (snd (assoc k' s)) with + | Rel k'' -> (k'', (b, specialize_constr s t')) + | _ -> error "Non-variable substituted for variable by strenghtening" + in map substsubst ((k, (b, t)) :: rest) + in + reduce_subst ctx' (compose_subst s substacc) rest' (* (compose_subst s ((k, (b, t)) :: rest)) *) + + +let substituted_context (subst : (int * constr) list) (ctx : rel_context) = + let _, subst = + fold_left (fun (k, s) _ -> + try let t = assoc k subst in + (succ k, (k, (true, t)) :: s) + with Not_found -> + (succ k, ((k, (false, mkRel k)) :: s))) + (1, []) ctx + in + let ctx', subst' = reduce_subst ctx subst subst in + reduce_rel_context ctx' subst' + +let unify_type before ty = + try + let envb = push_rel_context before (Global.env()) in + let IndType (indf, args) = find_rectype envb Evd.empty ty in + let ind, params = dest_ind_family indf in + let vs = map (Reduction.whd_betadeltaiota envb) args in + let cstrs = Inductiveops.arities_of_constructors envb ind in + let cstrs = + Array.mapi (fun i ty -> + let ty = prod_applist ty params in + let ctx, ty = decompose_prod_assum ty in + let ctx, ids = + let ids = ids_of_rel_context ctx in + fold_right (fun (n, b, t as decl) (acc, ids) -> + match n with Name _ -> (decl :: acc), ids + | Anonymous -> let id = next_name_away Anonymous ids in + ((Name id, b, t) :: acc), (id :: ids)) + ctx ([], ids) + in + let env' = push_rel_context ctx (Global.env ()) in + let IndType (indf, args) = find_rectype env' Evd.empty ty in + let ind, params = dest_ind_family indf in + let constr = applist (mkConstruct (ind, succ i), params @ rels_of_tele ctx) in + let constrpat = PCstr ((ind, succ i), inaccs_of_constrs params @ patvars_of_tele ctx) in + env', ctx, constr, constrpat, (* params @ *)args) + cstrs + in + let res = + Array.map (fun (env', ctxc, c, cpat, us) -> + let _beforelen = length before and ctxclen = length ctxc in + let fullctx = ctxc @ before in + try + let fullenv = push_rel_context fullctx (Global.env ()) in + let vs' = map (lift ctxclen) vs in + let subst = unify_constrs fullenv [] vs' us in + let subst', ctx' = substituted_context subst fullctx in + (ctx', ctxclen, c, cpat, Some subst') + with Conflict -> + (fullctx, ctxclen, c, cpat, None)) cstrs + in Some (res, indf) + with Not_found -> (* not an inductive type *) + None + +let rec id_of_rel n l = + match n, l with + | 0, (Name id, _, _) :: tl -> id + | n, _ :: tl -> id_of_rel (pred n) tl + | _, _ -> raise (Invalid_argument "id_of_rel") + +let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = + constrs_of_pats ~inacc (push_rel_context ctx env) pats + +let rec valid_splitting (f, delta, t, pats) tree = + split_solves tree (delta, f, pats) && + valid_splitting_tree (f, delta, t) tree + +and valid_splitting_tree (f, delta, t) = function + | Compute (lhs, Program rhs) -> + let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in + ignore(check_judgment (pi1 lhs) rhs (substl subst t)); true + + | Compute ((ctx, id, lhs), Empty split) -> + let before, (x, _, ty), after = split_context split ctx in + let unify = + match unify_type before ty with + | Some (unify, _) -> unify + | None -> assert false + in + array_for_all (fun (_, _, _, _, x) -> x = None) unify + + | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> + let before, (id, _, ty), after = split_tele (pred rel) ctx in + let unify, indf' = Option.get (unify_type before ty) in + assert(indf = indf'); + if not (array_exists (fun (_, _, _, _, x) -> x <> None) unify) then false + else + let ok, splits = + Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> + match subst with + | None -> acc + | Some subst -> +(* let env' = push_rel_context ctx' (Global.env ()) in *) +(* let ctx_correct = *) +(* ignore(check_context env' (subst_context subst ctxc)); *) +(* ignore(check_context env' (subst_context subst before)); *) +(* true *) +(* in *) + let newdelta = + subst_context subst (subst_rel_context 0 cstr + (lift_contextn ctxlen 0 after)) @ before in + let liftpats = lift_pats ctxlen rel lhs in + let newpats = specialize_patterns subst (subst_pats (Global.env ()) rel cstrpat liftpats) in + (ok, (f, newdelta, newpats) :: splits)) + (true, []) unify + in + let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta + (constrs_of_pats ~inacc:false (Global.env ()) lhs) + in + let t' = replace_vars subst t in + ok && for_all + (fun (f, delta', pats') -> + array_exists (function None -> false | Some tree -> valid_splitting (f, delta', t', pats') tree) ls) splits + +let valid_tree (f, delta, t) tree = + valid_splitting (f, delta, t, patvars_of_tele delta) tree + +let is_constructor c = + match kind_of_term (fst (decompose_app c)) with + | Construct _ -> true + | _ -> false + +let find_split (_, _, curpats : lhs) (_, _, patcs : lhs) = + let rec find_split_pat curpat patc = + match patc with + | PRel _ -> None + | PCstr (f, args) -> + (match curpat with + | PCstr (f', args') when f = f' -> (* Already split at this level, continue *) + find_split_pats args' args + | PRel i -> (* Split on i *) Some i + | PInac c when isRel c -> Some (destRel c) + | _ -> None) + | PInac _ -> None + + and find_split_pats curpats patcs = + assert(List.length curpats = List.length patcs); + fold_left2 (fun acc -> + match acc with + | None -> find_split_pat | _ -> fun _ _ -> acc) + None curpats patcs + in find_split_pats curpats patcs + +open Pp +open Termops + +let pr_constr_pat env c = + let pr = print_constr_env env c in + match kind_of_term c with + | App _ -> str "(" ++ pr ++ str ")" + | _ -> pr + +let pr_pat env c = + try + let patc = constr_of_pat env c in + try pr_constr_pat env patc with _ -> str"pr_constr_pat raised an exception" + with _ -> str"constr_of_pat raised an exception" + +let pr_context env c = + let pr_decl (id,b,_) = + let bstr = match b with Some b -> str ":=" ++ spc () ++ print_constr_env env b | None -> mt() in + let idstr = match id with Name id -> pr_id id | Anonymous -> str"_" in + idstr ++ bstr + in + prlist_with_sep pr_spc pr_decl (List.rev c) +(* Printer.pr_rel_context env c *) + +let pr_lhs env (delta, f, patcs) = + let env = push_rel_context delta env in + let ctx = pr_context env delta in + (if delta = [] then ctx else str "[" ++ ctx ++ str "]" ++ spc ()) + ++ pr_id f ++ spc () ++ prlist_with_sep spc (pr_pat env) patcs + +let pr_rhs env = function + | Empty var -> spc () ++ str ":=!" ++ spc () ++ print_constr_env env (mkRel var) + | Program rhs -> spc () ++ str ":=" ++ spc () ++ print_constr_env env rhs + +let pr_clause env (lhs, rhs) = + pr_lhs env lhs ++ + (let env' = push_rel_context (pi1 lhs) env in + pr_rhs env' rhs) + +(* let pr_splitting env = function *) +(* | Compute cl -> str "Compute " ++ pr_clause env cl *) +(* | Split (lhs, n, indf, results, splits) -> *) + +(* let pr_unification_result (ctx, n, c, pat, subst) = *) + +(* unification_result array * splitting option array *) + +let pr_clauses env = + prlist_with_sep fnl (pr_clause env) + +let lhs_includes (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = + pattern_includes patcs patcs' + +let lhs_matches (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = + pattern_matches patcs patcs' + +let rec split_on env var (delta, f, curpats as lhs) clauses = + let before, (id, _, ty), after = split_tele (pred var) delta in + let unify, indf = + match unify_type before ty with + | Some r -> r + | None -> assert false (* We decided... so it better be inductive *) + in + let clauses = ref clauses in + let splits = + Array.map (fun (ctx', ctxlen, cstr, cstrpat, s) -> + match s with + | None -> None + | Some s -> + (* ctx' |- s cstr, s cstrpat *) + let newdelta = + subst_context s (subst_rel_context 0 cstr + (lift_contextn ctxlen 1 after)) @ ctx' in + let liftpats = + (* delta |- curpats -> before; ctxc; id; after |- liftpats *) + lift_pats ctxlen (succ var) curpats + in + let liftpat = (* before; ctxc |- cstrpat -> before; ctxc; after |- liftpat *) + lift_pat (pred var) 1 cstrpat + in + let substpat = (* before; ctxc; after |- liftpats[id:=liftpat] *) + subst_pats env var liftpat liftpats + in + let lifts = (* before; ctxc |- s : newdelta -> + before; ctxc; after |- lifts : newdelta ; after *) + map (fun (k,(b,x)) -> (pred var + k, (b, lift (pred var) x))) s + in + let newpats = specialize_patterns lifts substpat in + let newlhs = (newdelta, f, newpats) in + let matching, rest = + fold_right (fun (lhs, rhs as clause) (matching, rest) -> + if lhs_includes newlhs lhs then + (clause :: matching, rest) + else (matching, clause :: rest)) + !clauses ([], []) + in + clauses := rest; + if matching = [] then ( + (* Try finding a splittable variable *) + let (id, _) = + fold_right (fun (id, _, ty as decl) (accid, ctx) -> + match accid with + | Some _ -> (accid, ctx) + | None -> + match unify_type ctx ty with + | Some (unify, indf) -> + if array_for_all (fun (_, _, _, _, x) -> x = None) unify then + (Some id, ctx) + else (None, decl :: ctx) + | None -> (None, decl :: ctx)) + newdelta (None, []) + in + match id with + | None -> + errorlabstrm "deppat" + (str "Non-exhaustive pattern-matching, no clause found for:" ++ fnl () ++ + pr_lhs env newlhs) + | Some id -> + Some (Compute (newlhs, Empty (fst (lookup_rel_id (out_name id) newdelta)))) + ) else ( + let splitting = make_split_aux env newlhs matching in + Some splitting)) + unify + in +(* if !clauses <> [] then *) +(* errorlabstrm "deppat" *) +(* (str "Impossible clauses:" ++ fnl () ++ pr_clauses env !clauses); *) + Split (lhs, var, indf, unify, splits) + +and make_split_aux env lhs clauses = + let split = + fold_left (fun acc (lhs', rhs) -> + match acc with + | None -> find_split lhs lhs' + | _ -> acc) None clauses + in + match split with + | Some var -> split_on env var lhs clauses + | None -> + (match clauses with + | [] -> error "No clauses left" + | [(lhs', rhs)] -> + (* No need to split anymore, fix the environments so that they are correctly aligned. *) + (match lhs_matches lhs' lhs with + | Some s -> + let s = map (fun (x, p) -> x, (true, constr_of_pat ~inacc:false env p)) s in + let rhs' = match rhs with + | Program c -> Program (specialize_constr s c) + | Empty i -> Empty (destRel (snd (assoc i s))) + in Compute ((pi1 lhs, pi2 lhs, specialize_patterns s (pi3 lhs')), rhs') + | None -> anomaly "Non-matching clauses at a leaf of the splitting tree") + | _ -> + errorlabstrm "make_split_aux" + (str "Overlapping clauses:" ++ fnl () ++ pr_clauses env clauses)) + +let make_split env (f, delta, t) clauses = + make_split_aux env (delta, f, patvars_of_tele delta) clauses + +open Evd +open Evarutil + +let lift_substitution n s = map (fun (k, x) -> (k + n, x)) s +let map_substitution s t = map (subst_rel_subst 0 s) t + +let term_of_tree status isevar env (i, delta, ty) ann tree = +(* let envrec = match ann with *) +(* | None -> [] *) +(* | Some (loc, i) -> *) +(* let (n, t) = lookup_rel_id i delta in *) +(* let t' = lift n t in *) + + +(* in *) + let rec aux = function + | Compute ((ctx, _, pats as lhs), Program rhs) -> + let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in + let body = it_mkLambda_or_LetIn rhs ctx and typ = it_mkProd_or_LetIn ty' ctx in + mkCast(body, DEFAULTcast, typ), typ + + | Compute ((ctx, _, pats as lhs), Empty split) -> + let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in + let split = (Name (id_of_string "split"), + Some (Class_tactics.coq_nat_of_int (1 + (length ctx - split))), + Lazy.force Class_tactics.coq_nat) + in + let ty' = it_mkProd_or_LetIn ty' ctx in + let let_ty' = mkLambda_or_LetIn split (lift 1 ty') in + let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark (Define true)) let_ty' in + term, ty' + + | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> + let before, decl, after = split_tele (pred rel) ctx in + let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in + let branches = + array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> + match split with + | Some s -> aux s + | None -> + (* dead code, inversion will find a proof of False by splitting on the rel'th hyp *) + Class_tactics.coq_nat_of_int rel, Lazy.force Class_tactics.coq_nat) + unif sp + in + let branches_ctx = + Array.mapi (fun i (br, brt) -> (id_of_string ("m_" ^ string_of_int i), Some br, brt)) + branches + in + let n, branches_lets = + Array.fold_left (fun (n, lets) (id, b, t) -> + (succ n, (Name id, Option.map (lift n) b, lift n t) :: lets)) + (0, []) branches_ctx + in + let liftctx = lift_contextn (Array.length branches) 0 ctx in + let case = + let ty = it_mkProd_or_LetIn ty' liftctx in + let ty = it_mkLambda_or_LetIn ty branches_lets in + let nbbranches = (Name (id_of_string "branches"), + Some (Class_tactics.coq_nat_of_int (length branches_lets)), + Lazy.force Class_tactics.coq_nat) + in + let nbdiscr = (Name (id_of_string "target"), + Some (Class_tactics.coq_nat_of_int (length before)), + Lazy.force Class_tactics.coq_nat) + in + let ty = it_mkLambda_or_LetIn (lift 2 ty) [nbbranches;nbdiscr] in + let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark status) ty in + term + in + let casetyp = it_mkProd_or_LetIn ty' ctx in + mkCast(case, DEFAULTcast, casetyp), casetyp + + in aux tree + +open Topconstr +open Constrintern +open Decl_kinds + +type equation = constr_expr * (constr_expr, identifier located) rhs + +let locate_reference qid = + match Nametab.extended_locate qid with + | TrueGlobal ref -> true + | SyntacticDef kn -> true + +let is_global id = + try + locate_reference (make_short_qualid id) + with Not_found -> + false + +let is_freevar ids env x = + try + if Idset.mem x ids then false + else + try ignore(Environ.lookup_named x env) ; false + with _ -> not (is_global x) + with _ -> true + +let ids_of_patc c ?(bound=Idset.empty) l = + let found id bdvars l = + if not (is_freevar bdvars (Global.env ()) (snd id)) then l + else if List.exists (fun (_, id') -> id' = snd id) l then l + else id :: l + in + let rec aux bdvars l c = match c with + | CRef (Ident lid) -> found lid bdvars l + | CNotation (_, "{ _ : _ | _ }", ((CRef (Ident (_, id))) :: _, _)) when not (Idset.mem id bdvars) -> + fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c + | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c + in aux bound l c + +let interp_pats i isevar env impls pat sign recu = + let bound = Idset.singleton i in + let vars = ids_of_patc pat ~bound [] in + let varsctx, env' = + fold_right (fun (loc, id) (ctx, env) -> + let decl = + let ty = e_new_evar isevar env ~src:(loc, BinderType (Name id)) (new_Type ()) in + (Name id, None, ty) + in + decl::ctx, push_rel decl env) + vars ([], env) + in + let pats = + let patenv = match recu with None -> env' | Some ty -> push_named (i, None, ty) env' in + let patt, _ = interp_constr_evars_impls ~evdref:isevar patenv ~impls:([],[]) pat in + match kind_of_term patt with + | App (m, args) -> + if not (eq_constr m (mkRel (succ (length varsctx)))) then + user_err_loc (constr_loc pat, "interp_pats", + str "Expecting a pattern for " ++ pr_id i) + else Array.to_list args + | _ -> user_err_loc (constr_loc pat, "interp_pats", + str "Error parsing pattern: unnexpected left-hand side") + in + isevar := nf_evar_defs !isevar; + (nf_rel_context_evar (Evd.evars_of !isevar) varsctx, + nf_env_evar (Evd.evars_of !isevar) env', + rev_map (nf_evar (Evd.evars_of !isevar)) pats) + +let interp_eqn i isevar env impls sign arity recu (pats, rhs) = + let ctx, env', patcs = interp_pats i isevar env impls pats sign recu in + let rhs' = match rhs with + | Program p -> + let ty = nf_isevar !isevar (substl patcs arity) in + Program (interp_casted_constr_evars isevar env' ~impls p ty) + | Empty lid -> Empty (fst (lookup_rel_id (snd lid) ctx)) + in ((ctx, i, pats_of_constrs (rev patcs)), rhs') + +open Entries + +open Tacmach +open Tacexpr +open Tactics +open Tacticals + +let contrib_tactics_path = + make_dirpath (List.map id_of_string ["Equality";"Program";"Coq"]) + +let tactics_tac s = + make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s) + +let equations_tac = lazy + (Tacinterp.eval_tactic + (TacArg(TacCall(dummy_loc, + ArgArg(dummy_loc, tactics_tac "equations"), [])))) + +let define_by_eqs with_comp i (l,ann) t nt eqs = + let env = Global.env () in + let isevar = ref (create_evar_defs Evd.empty) in + let (env', sign), impls = interp_context_evars isevar env l in + let arity = interp_type_evars isevar env' t in + let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in + let arity = nf_evar (Evd.evars_of !isevar) arity in + let arity = + if with_comp then + let compid = add_suffix i "_comp" in + let ce = + { const_entry_body = it_mkLambda_or_LetIn arity sign; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = false} + in + let c = + Declare.declare_constant compid (DefinitionEntry ce, IsDefinition Definition) + in mkApp (mkConst c, rel_vect 0 (length sign)) + else arity + in + let env = Global.env () in + let ty = it_mkProd_or_LetIn arity sign in + let data = Command.compute_interning_datas env Constrintern.Recursive [] [i] [ty] [impls] in + let fixdecls = [(Name i, None, ty)] in + let fixenv = push_rel_context fixdecls env in + let equations = + States.with_heavy_rollback (fun () -> + Option.iter (Command.declare_interning_data data) nt; + map (interp_eqn i isevar fixenv data sign arity None) eqs) () + in + let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in + let arity = nf_evar (Evd.evars_of !isevar) arity in + let prob = (i, sign, arity) in + let fixenv = nf_env_evar (Evd.evars_of !isevar) fixenv in + let fixdecls = nf_rel_context_evar (Evd.evars_of !isevar) fixdecls in + (* let ce = check_evars fixenv Evd.empty !isevar in *) + (* List.iter (function (_, _, Program rhs) -> ce rhs | _ -> ()) equations; *) + let is_recursive, env' = + let occur_eqn ((ctx, _, _), rhs) = + match rhs with + | Program c -> dependent (mkRel (succ (length ctx))) c + | _ -> false + in if exists occur_eqn equations then true, fixenv else false, env + in + let split = make_split env' prob equations in + (* if valid_tree prob split then *) + let status = (* if is_recursive then Expand else *) Define false in + let t, ty = term_of_tree status isevar env' prob ann split in + let undef = undefined_evars !isevar in + let t, ty = if is_recursive then + (it_mkLambda_or_LetIn t fixdecls, it_mkProd_or_LetIn ty fixdecls) + else t, ty + in + let obls, t', ty' = + Eterm.eterm_obligations env i !isevar (Evd.evars_of undef) 0 ~status t ty + in + if is_recursive then + ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] + ~tactic:(Lazy.force equations_tac) + (Command.IsFixpoint [None, CStructRec])) + else + ignore(Subtac_obligations.add_definition + ~implicits:impls i t' ty' ~tactic:(Lazy.force equations_tac) obls) + +module Gram = Pcoq.Gram +module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic + +module DeppatGram = +struct + let gec s = Gram.Entry.create ("Deppat."^s) + + let deppat_equations : equation list Gram.Entry.e = gec "deppat_equations" + + let binders_let2 : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e = gec "binders_let2" + +(* let where_decl : decl_notation Gram.Entry.e = gec "where_decl" *) + +end + +open Rawterm +open DeppatGram +open Util +open Pcoq +open Prim +open Constr +open G_vernac + +GEXTEND Gram + GLOBAL: (* deppat_gallina_loc *) deppat_equations binders_let2; + + deppat_equations: + [ [ l = LIST1 equation SEP ";" -> l ] ] + ; + + binders_let2: + [ [ l = binders_let_fixannot -> l ] ] + ; + + equation: + [ [ c = Constr.lconstr; r=rhs -> (c, r) ] ] + ; + + rhs: + [ [ ":=!"; id = identref -> Empty id + |":="; c = Constr.lconstr -> Program c + ] ] + ; + + END + +type 'a deppat_equations_argtype = (equation list, 'a) Genarg.abstract_argument_type + +let (wit_deppat_equations : Genarg.tlevel deppat_equations_argtype), + (globwit_deppat_equations : Genarg.glevel deppat_equations_argtype), + (rawwit_deppat_equations : Genarg.rlevel deppat_equations_argtype) = + Genarg.create_arg "deppat_equations" + +type 'a binders_let2_argtype = (local_binder list * (identifier located option * recursion_order_expr), 'a) Genarg.abstract_argument_type + +let (wit_binders_let2 : Genarg.tlevel binders_let2_argtype), + (globwit_binders_let2 : Genarg.glevel binders_let2_argtype), + (rawwit_binders_let2 : Genarg.rlevel binders_let2_argtype) = + Genarg.create_arg "binders_let2" + +type 'a decl_notation_argtype = (Vernacexpr.decl_notation, 'a) Genarg.abstract_argument_type + +let (wit_decl_notation : Genarg.tlevel decl_notation_argtype), + (globwit_decl_notation : Genarg.glevel decl_notation_argtype), + (rawwit_decl_notation : Genarg.rlevel decl_notation_argtype) = + Genarg.create_arg "decl_notation" + +let equations wc i l t nt eqs = + try define_by_eqs wc i l t nt eqs + with e -> msg (Cerrors.explain_exn e) + +VERNAC COMMAND EXTEND Define_equations +| [ "Equations" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs) + decl_notation(nt) ] -> + [ equations true i l t nt eqs ] + END + +VERNAC COMMAND EXTEND Define_equations2 +| [ "Equations_nocomp" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs) + decl_notation(nt) ] -> + [ equations false i l t nt eqs ] +END + +let rec int_of_coq_nat c = + match kind_of_term c with + | App (f, [| arg |]) -> succ (int_of_coq_nat arg) + | _ -> 0 + +let solve_equations_goal destruct_tac tac gl = + let concl = pf_concl gl in + let targetn, branchesn, targ, brs, b = + match kind_of_term concl with + | LetIn (Name target, targ, _, b) -> + (match kind_of_term b with + | LetIn (Name branches, brs, _, b) -> + target, branches, int_of_coq_nat targ, int_of_coq_nat brs, b + | _ -> error "Unnexpected goal") + | _ -> error "Unnexpected goal" + in + let branches, b = + let rec aux n c = + if n = 0 then [], c + else match kind_of_term c with + | LetIn (Name id, br, brt, b) -> + let rest, b = aux (pred n) b in + (id, br, brt) :: rest, b + | _ -> error "Unnexpected goal" + in aux brs b + in + let ids = targetn :: branchesn :: map pi1 branches in + let cleantac = tclTHEN (intros_using ids) (thin ids) in + let dotac = tclDO (succ targ) intro in + let subtacs = + tclTHENS destruct_tac + (map (fun (id, br, brt) -> tclTHEN (letin_tac None (Name id) br (Some brt) onConcl) tac) branches) + in tclTHENLIST [cleantac ; dotac ; subtacs] gl + +TACTIC EXTEND solve_equations + [ "solve_equations" tactic(destruct) tactic(tac) ] -> [ solve_equations_goal (snd destruct) (snd tac) ] + END + +let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq +let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) + +let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") +let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") + +let specialize_hyp id gl = + let env = pf_env gl in + let ty = pf_get_hyp_typ gl id in + let evars = ref (create_evar_defs (project gl)) in + let rec aux in_eqs acc ty = + match kind_of_term ty with + | Prod (_, t, b) -> + (match kind_of_term t with + | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> + let pt = mkApp (Lazy.force coq_eq, [| eqty; x; x |]) in + let p = mkApp (Lazy.force coq_eq_refl, [| eqty; x |]) in + if e_conv env evars pt t then + aux true (mkApp (acc, [| p |])) (subst1 p b) + else error "Unconvertible members of an homogeneous equality" + | App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) -> + let pt = mkApp (Lazy.force coq_heq, [| eqty; x; eqty; x |]) in + let p = mkApp (Lazy.force coq_heq_refl, [| eqty; x |]) in + if e_conv env evars pt t then + aux true (mkApp (acc, [| p |])) (subst1 p b) + else error "Unconvertible members of an heterogeneous equality" + | _ -> + if in_eqs then acc, in_eqs, ty + else + let e = e_new_evar evars env t in + aux false (mkApp (acc, [| e |])) (subst1 e b)) + | t -> acc, in_eqs, ty + in + try + let acc, worked, ty = aux false (mkVar id) ty in + let ty = Evarutil.nf_isevar !evars ty in + if worked then + tclTHENFIRST + (fun g -> Tacmach.internal_cut true id ty g) + (exact_no_check (Evarutil.nf_isevar !evars acc)) gl + else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl + with e -> tclFAIL 0 (Cerrors.explain_exn e) gl + +TACTIC EXTEND specialize_hyp +[ "specialize_hypothesis" constr(c) ] -> [ + match kind_of_term c with + | Var id -> specialize_hyp id + | _ -> tclFAIL 0 (str "Not an hypothesis") ] +END diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 9bfb33ea..00a69bba 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -1,3 +1,4 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) (** - Get types of existentials ; - Flatten dependency tree (prefix order) ; @@ -6,12 +7,14 @@ *) open Term +open Sign open Names open Evd open List open Pp open Util open Subtac_utils +open Proof_type let trace s = if !Flags.debug then (msgnl s; msgerr s) @@ -20,15 +23,27 @@ let trace s = let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) +type oblinfo = + { ev_name: int * identifier; + ev_hyps: named_context; + ev_status: obligation_definition_status; + ev_chop: int option; + ev_loc: Util.loc; + ev_typ: types; + ev_tac: Tacexpr.raw_tactic_expr option; + ev_deps: Intset.t } + (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) + let subst_evar_constr evs n t = let seen = ref Intset.empty in let transparent = ref Idset.empty in let evar_info id = List.assoc id evs in let rec substrec (depth, fixrels) c = match kind_of_term c with | Evar (k, args) -> - let (id, idstr), hyps, chop, _, _, _ = + let { ev_name = (id, idstr) ; + ev_hyps = hyps ; ev_chop = chop } = try evar_info k with Not_found -> anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") @@ -46,17 +61,13 @@ let subst_evar_constr evs n t = let rec aux hyps args acc = match hyps, args with ((_, None, _) :: tlh), (c :: tla) -> - aux tlh tla ((map_constr_with_binders succfix substrec (depth, fixrels) c) :: acc) + aux tlh tla ((substrec (depth, fixrels) c) :: acc) | ((_, Some _, _) :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) in aux hyps args [] in - (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (List.length args) ++ str "arguments," ++ - int (List.length hyps) ++ str " hypotheses" ++ spc () ++ - pp_list (fun x -> my_print_constr (Global.env ()) x) args); - with _ -> ()); if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then transparent := Idset.add idstr !transparent; mkApp (mkVar idstr, Array.of_list args) @@ -93,8 +104,8 @@ let etype_of_evar evs hyps concl = let trans' = Idset.union trans trans' in (match copt with Some c -> - if noccurn 1 rest then lift (-1) rest, s', trans' - else +(* if noccurn 1 rest then lift (-1) rest, s', trans' *) +(* else *) let c', s'', trans'' = subst_evar_constr evs n c in let c' = subst_vars acc 0 c' in mkNamedProd_or_LetIn (id, Some c', t'') rest, @@ -121,15 +132,34 @@ let rec chop_product n t = | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None -let eterm_obligations env name isevars evm fs t ty = - (* 'Serialize' the evars, we assume that the types of the existentials - refer to previous existentials in the list only *) - trace (str " In eterm: isevars: " ++ my_print_evardefs isevars); - trace (str "Term given to eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t); +let evar_dependencies evm ev = + let one_step deps = + Intset.fold (fun ev s -> + let evi = Evd.find evm ev in + Intset.union (Evarutil.evars_of_evar_info evi) s) + deps deps + in + let rec aux deps = + let deps' = one_step deps in + if Intset.equal deps deps' then deps + else aux deps' + in aux (Intset.singleton ev) + +let sort_dependencies evl = + List.sort (fun (_, _, deps) (_, _, deps') -> + if Intset.subset deps deps' then (* deps' depends on deps *) -1 + else if Intset.subset deps' deps then 1 + else Intset.compare deps deps') + evl + +let eterm_obligations env name isevars evm fs ?status t ty = + (* 'Serialize' the evars *) let nc = Environ.named_context env in let nc_len = Sign.named_context_length nc in let evl = List.rev (to_list evm) in + let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in + let sevl = sort_dependencies evl in + let evl = List.map (fun (id, ev, _) -> id, ev) sevl in let evn = let i = ref (-1) in List.rev_map (fun (id, ev) -> incr i; @@ -146,20 +176,29 @@ let eterm_obligations env name isevars evm fs t ty = let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in let evtyp, hyps, chop = match chop_product fs evtyp with - Some t -> - (try - trace (str "Choped a product: " ++ spc () ++ - Termops.print_constr_env (Global.env ()) evtyp ++ str " to " ++ spc () ++ - Termops.print_constr_env (Global.env ()) t); - with _ -> ()); - t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 + | Some t -> t, trunc_named_context fs hyps, fs + | None -> evtyp, hyps, 0 in let loc, k = evar_source id isevars in - let opacity = match k with QuestionMark o -> o | _ -> true in - let opaque = if not opacity || chop <> fs then None else Some chop in - let y' = (id, ((n, nstr), hyps, opaque, loc, evtyp, deps)) in - y' :: l) + let status = match k with QuestionMark o -> Some o | _ -> status in + let status, chop = match status with + | Some (Define true as stat) -> + if chop <> fs then Define false, None + else stat, Some chop + | Some s -> s, None + | None -> Define true, None + in + let tac = match ev.evar_extra with + | Some t -> + if Dyn.tag t = "tactic" then + Some (Tacinterp.globTacticIn (Tacinterp.tactic_out t)) + else None + | None -> None + in + let info = { ev_name = (n, nstr); + ev_hyps = hyps; ev_status = status; ev_chop = chop; + ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } + in (id, info) :: l) evn [] in let t', _, transparent = (* Substitute evar refs in the term by variables *) @@ -167,28 +206,16 @@ let eterm_obligations env name isevars evm fs t ty = in let ty, _, _ = subst_evar_constr evts 0 ty in let evars = - List.map (fun (_, ((_, name), _, opaque, loc, typ, deps)) -> - name, typ, loc, not (opaque = None) && not (Idset.mem name transparent), deps) evts - in - (try - trace (str "Term constructed in eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t'); - ignore(iter - (fun (name, typ, _, _, deps) -> - trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ - Termops.print_constr_env (Global.env ()) typ)) - evars); - with _ -> ()); - Array.of_list (List.rev evars), t', ty + List.map (fun (_, info) -> + let { ev_name = (_, name); ev_status = status; + ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info + in + let status = match status with + | Define true when Idset.mem name transparent -> Define false + | _ -> status + in name, typ, loc, status, deps, tac) evts + in Array.of_list (List.rev evars), t', ty let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n -(* let eterm evm t (tycon : types option) = *) -(* let t, tycon, evs = eterm_term evm t tycon in *) -(* match tycon with *) -(* Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) [] *) -(* | None -> Tactics.apply_term t (mkMetas (List.length evs)) *) - -(* open Tacmach *) - let etermtac (evm, t) = assert(false) (*eterm evm t None *) diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli index 007e327c..19e8ffe8 100644 --- a/contrib/subtac/eterm.mli +++ b/contrib/subtac/eterm.mli @@ -6,23 +6,27 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: eterm.mli 10889 2008-05-06 14:05:20Z msozeau $ i*) +(*i $Id: eterm.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) open Environ open Tacmach open Term open Evd open Names open Util +open Tacinterp val mkMetas : int -> constr list -(* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *) - -(* env, id, evars, number of - function prototypes to try to clear from evars contexts, object and type *) -val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> constr -> types -> - (identifier * types * loc * bool * Intset.t) array * constr * types - (* Obl. name, type as product, location of the original evar, - opacity (true = opaque) and dependencies as indexes into the array *) +val evar_dependencies : evar_map -> int -> Intset.t +val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list + +(* env, id, evars, number of function prototypes to try to clear from + evars contexts, object and type *) +val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> + ?status:obligation_definition_status -> constr -> types -> + (identifier * types * loc * obligation_definition_status * Intset.t * + Tacexpr.raw_tactic_expr option) array * constr * types + (* Obl. name, type as product, location of the original evar, associated tactic, + status and dependencies as indexes into the array *) val etermtac : open_constr -> tactic diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 index 4cf5336d..7194d435 100644 --- a/contrib/subtac/g_subtac.ml4 +++ b/contrib/subtac/g_subtac.ml4 @@ -14,7 +14,7 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliātre *) -(* $Id: g_subtac.ml4 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: g_subtac.ml4 11576 2008-11-10 19:13:15Z msozeau $ *) open Flags @@ -112,25 +112,25 @@ END VERNAC COMMAND EXTEND Subtac_Solve_Obligation | [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligation num (Some name) (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligation num None (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligation num None (Some (Tacinterp.interp t)) ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligations | [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligations (Some name) (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligations None (Tacinterp.interp t) ] + [ Subtac_obligations.try_solve_obligations None (Some (Tacinterp.interp t)) ] | [ "Solve" "Obligations" ] -> - [ Subtac_obligations.try_solve_obligations None (Subtac_obligations.default_tactic ()) ] + [ Subtac_obligations.try_solve_obligations None None ] END VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations | [ "Solve" "All" "Obligations" "using" tactic(t) ] -> - [ Subtac_obligations.solve_all_obligations (Tacinterp.interp t) ] + [ Subtac_obligations.solve_all_obligations (Some (Tacinterp.interp t)) ] | [ "Solve" "All" "Obligations" ] -> - [ Subtac_obligations.solve_all_obligations (Subtac_obligations.default_tactic ()) ] + [ Subtac_obligations.solve_all_obligations None ] END VERNAC COMMAND EXTEND Subtac_Admit_Obligations diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index 7bfa107b..ba00fce5 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id: subtac.ml 11800 2009-01-18 18:34:15Z msozeau $ *) open Global open Pp @@ -52,16 +52,14 @@ open Tacexpr let solve_tccs_in_type env id isevars evm c typ = if not (evm = Evd.empty) then let stmt_id = Nameops.add_suffix id "_stmt" in - let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 c typ in - (** Make all obligations transparent so that real dependencies can be sorted out by the user *) - let obls = Array.map (fun (id, t, l, op, d) -> (id, t, l, false, d)) obls in + let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in match Subtac_obligations.add_definition stmt_id c' typ obls with - Subtac_obligations.Defined cst -> constant_value (Global.env()) - (match cst with ConstRef kn -> kn | _ -> assert false) - | _ -> - errorlabstrm "start_proof" - (str "The statement obligations could not be resolved automatically, " ++ spc () ++ - str "write a statement definition first.") + Subtac_obligations.Defined cst -> constant_value (Global.env()) + (match cst with ConstRef kn -> kn | _ -> assert false) + | _ -> + errorlabstrm "start_proof" + (str "The statement obligations could not be resolved automatically, " ++ spc () ++ + str "write a statement definition first.") else let _ = Typeops.infer_type env c in c @@ -106,12 +104,9 @@ let declare_assumption env isevars idl is_coe k bl c nl = errorlabstrm "Command.Assumption" (str "Cannot declare an assumption while in proof editing mode.") -let dump_definition (loc, id) s = - Flags.dump_string (Printf.sprintf "%s %d %s\n" s (fst (unloc loc)) (string_of_id id)) - let dump_constraint ty ((loc, n), _, _) = match n with - | Name id -> dump_definition (loc, id) ty + | Name id -> Dumpglob.dump_definition (loc, id) false ty | Anonymous -> () let dump_variable lid = () @@ -119,9 +114,9 @@ let dump_variable lid = () let vernac_assumption env isevars kind l nl = let global = fst kind = Global in List.iter (fun (is_coe,(idl,c)) -> - if !Flags.dump then + if Dumpglob.dump () then List.iter (fun lid -> - if global then dump_definition lid "ax" + if global then Dumpglob.dump_definition lid (not global) "ax" else dump_variable lid) idl; declare_assumption env isevars idl is_coe kind [] c nl) l @@ -139,7 +134,7 @@ let subtac (loc, command) = match command with | VernacDefinition (defkind, (_, id as lid), expr, hook) -> check_fresh lid; - dump_definition lid "def"; + Dumpglob.dump_definition lid false "def"; (match expr with | ProveBody (bl, t) -> if Lib.is_modtype () then @@ -152,12 +147,12 @@ let subtac (loc, command) = | VernacFixpoint (l, b) -> List.iter (fun ((lid, _, _, _, _), _) -> check_fresh lid; - dump_definition lid "fix") l; + Dumpglob.dump_definition lid false "fix") l; let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l b) | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) -> - if !Flags.dump then dump_definition id "prf"; + Dumpglob.dump_definition id false "prf"; if not(Pfedit.refining ()) then if lettop then errorlabstrm "Subtac_command.StartProof" @@ -172,11 +167,12 @@ let subtac (loc, command) = vernac_assumption env isevars stre l nl | VernacInstance (glob, sup, is, props, pri) -> - if !Flags.dump then dump_constraint "inst" is; + dump_constraint "inst" is; ignore(Subtac_classes.new_instance ~global:glob sup is props pri) | VernacCoFixpoint (l, b) -> - List.iter (fun ((lid, _, _, _), _) -> dump_definition lid "cofix") l; + if Dumpglob.dump () then + List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; ignore(Subtac_command.build_corecursive l b) (*| VernacEndProof e -> diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml index 04bf54d3..094226ff 100644 --- a/contrib/subtac/subtac_cases.ml +++ b/contrib/subtac/subtac_cases.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_cases.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: subtac_cases.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Cases open Util @@ -1572,7 +1572,7 @@ let mk_JMeq typ x typ' y = mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |]) -let hole = RHole (dummy_loc, Evd.QuestionMark true) +let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) let context_of_arsign l = let (x, _) = List.fold_right diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml index 9a5539e2..0d44a0c0 100644 --- a/contrib/subtac/subtac_classes.ml +++ b/contrib/subtac/subtac_classes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtac_classes.ml 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: subtac_classes.ml 11800 2009-01-18 18:34:15Z msozeau $ i*) open Pretyping open Evd @@ -92,104 +92,103 @@ let type_class_instance_params isevars env id n ctx inst subst = let substitution_of_constrs ctx cstrs = List.fold_right2 (fun c (na, _, _) acc -> (na, c) :: acc) cstrs ctx [] -let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=Classes.default_on_free_vars) pri = +let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri = let env = Global.env() in let isevars = ref (Evd.create_evar_defs Evd.empty) in - let bound = Implicit_quantifiers.ids_of_list (Termops.ids_of_context env) in - let bound, fvs = Implicit_quantifiers.free_vars_of_binders ~bound [] ctx in let tclass = match bk with - | Implicit -> - let loc, id, par = Implicit_quantifiers.destClassAppExpl cl in - let k = class_info (Nametab.global id) in - let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in - let needlen = List.fold_left (fun acc (x, y) -> if x = None then succ acc else acc) 0 k.cl_context in - if needlen <> applen then - Classes.mismatched_params env (List.map fst par) (List.map snd k.cl_context); - let pars, _ = Implicit_quantifiers.combine_params Idset.empty (* need no avoid *) - (fun avoid (clname, (id, _, t)) -> - match clname with - Some (cl, b) -> - let t = - if b then - let _k = class_info cl in - CHole (Util.dummy_loc, Some Evd.InternalHole) (* (Evd.ImplicitArg (IndRef k.cl_impl, (1, None)))) *) - else CHole (Util.dummy_loc, None) - in t, avoid - | None -> failwith ("new instance: under-applied typeclass")) - par (List.rev k.cl_context) - in Topconstr.CAppExpl (loc, (None, id), pars) - + | Implicit -> + Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *) + ~allow_partial:false (fun avoid (clname, (id, _, t)) -> + match clname with + | Some (cl, b) -> + let t = + if b then + let _k = class_info cl in + CHole (Util.dummy_loc, Some Evd.InternalHole) + else CHole (Util.dummy_loc, None) + in t, avoid + | None -> failwith ("new instance: under-applied typeclass")) + cl | Explicit -> cl in - let ctx_bound = Idset.union bound (Implicit_quantifiers.ids_of_list fvs) in - let gen_ids = Implicit_quantifiers.free_vars_of_constr_expr ~bound:ctx_bound tclass [] in - let bound = Idset.union (Implicit_quantifiers.ids_of_list gen_ids) ctx_bound in - on_free_vars (List.rev (gen_ids @ fvs)); - let gen_ctx = Implicit_quantifiers.binder_list_of_ids gen_ids in - let ctx, avoid = Classes.name_typeclass_binders bound ctx in - let ctx = List.append ctx (List.rev gen_ctx) in + let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in let k, ctx', imps, subst = let c = Command.generalize_constr_expr tclass ctx in let c', imps = interp_type_evars_impls ~evdref:isevars env c in let ctx, c = Sign.decompose_prod_assum c' in - let cl, args = Typeclasses.dest_class_app c in - cl, ctx, imps, (List.rev (Array.to_list args)) + let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in + cl, ctx, imps, (List.rev args) in let id = match snd instid with - Name id -> - let sp = Lib.make_path id in - if Nametab.exists_cci sp then - errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); - id - | Anonymous -> - let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in - Termops.next_global_ident_away false i (Termops.ids_of_context env) + | Name id -> + let sp = Lib.make_path id in + if Nametab.exists_cci sp then + errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); + id + | Anonymous -> + let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in + Termops.next_global_ident_away false i (Termops.ids_of_context env) in let env' = push_rel_context ctx' env in isevars := Evarutil.nf_evar_defs !isevars; isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars; let sigma = Evd.evars_of !isevars in - let substctx = List.map (Evarutil.nf_evar sigma) subst in - let subst, _propsctx = + let subst = List.map (Evarutil.nf_evar sigma) subst in + let subst = let props = - List.map (fun (x, l, d) -> - x, Topconstr.abstract_constr_expr d (Classes.binders_of_lidents l)) - props + match props with + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then + Classes.mismatched_props env' (List.map snd fs) k.cl_props; + fs + | _ -> + if List.length k.cl_props <> 1 then + errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") + else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] in - if List.length props > List.length k.cl_props then - Classes.mismatched_props env' (List.map snd props) k.cl_props; - let props, rest = - List.fold_left - (fun (props, rest) (id,_,_) -> - try - let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in - let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in - Constrintern.add_glob loc (ConstRef (List.assoc mid k.cl_projs)); - c :: props, rest' - with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) - ([], props) k.cl_props - in - if rest <> [] then - unbound_method env' k.cl_impl (fst (List.hd rest)) - else - type_ctx_instance isevars env' k.cl_props props substctx + match k.cl_props with + | [(na,b,ty)] -> + let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in + let ty' = substl subst ty in + let c = interp_casted_constr_evars isevars env' term ty' in + c :: subst + | _ -> + let props, rest = + List.fold_left + (fun (props, rest) (id,_,_) -> + try + let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in + let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); + c :: props, rest' + with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) + ([], props) k.cl_props + in + if rest <> [] then + unbound_method env' k.cl_impl (fst (List.hd rest)) + else + fst (type_ctx_instance isevars env' k.cl_props props subst) + in + let subst = List.fold_left2 + (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') + [] subst (k.cl_props @ snd k.cl_context) in - let inst_constr, ty_constr = instance_constructor k (List.rev subst) in - isevars := Evarutil.nf_evar_defs !isevars; - let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx') - and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') + let inst_constr, ty_constr = instance_constructor k subst in + isevars := Evarutil.nf_evar_defs !isevars; + let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx') + and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') + in + isevars := undefined_evars !isevars; + Evarutil.check_evars env Evd.empty !isevars termtype; + let hook gr = + let cst = match gr with ConstRef kn -> kn | _ -> assert false in + let inst = Typeclasses.new_instance k pri global cst in + Impargs.declare_manual_implicits false gr ~enriching:false imps; + Typeclasses.add_instance inst in - isevars := undefined_evars !isevars; - Evarutil.check_evars env Evd.empty !isevars termtype; - let hook gr = - let cst = match gr with ConstRef kn -> kn | _ -> assert false in - let inst = Typeclasses.new_instance k pri global cst in - Impargs.declare_manual_implicits false gr false imps; - Typeclasses.add_instance inst - in - let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in - let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in - ignore(Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls); - id + let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in + let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in + id, Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls + diff --git a/contrib/subtac/subtac_classes.mli b/contrib/subtac/subtac_classes.mli index afb0d38d..96a51027 100644 --- a/contrib/subtac/subtac_classes.mli +++ b/contrib/subtac/subtac_classes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtac_classes.mli 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: subtac_classes.mli 11709 2008-12-20 11:42:15Z msozeau $ i*) (*i*) open Names @@ -34,9 +34,9 @@ val type_ctx_instance : Evd.evar_defs ref -> val new_instance : ?global:bool -> - Topconstr.local_binder list -> + local_binder list -> typeclass_constraint -> - binder_def_list -> - ?on_free_vars:(identifier list -> unit) -> + constr_expr -> + ?generalize:bool -> int option -> - identifier + identifier * Subtac_obligations.progress diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index 4d8f868f..1bbbfbb1 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 11343 2008-09-01 20:55:13Z herbelin $ *) +(* $Id: subtac_coercion.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Util open Names @@ -33,37 +33,36 @@ open Pp let pair_of_array a = (a.(0), a.(1)) let make_name s = Name (id_of_string s) +let rec disc_subset x = + match kind_of_term x with + | App (c, l) -> + (match kind_of_term c with + Ind i -> + let len = Array.length l in + let sig_ = Lazy.force sig_ in + if len = 2 && i = Term.destInd sig_.typ + then + let (a, b) = pair_of_array l in + Some (a, b) + else None + | _ -> None) + | _ -> None + +and disc_exist env x = + match kind_of_term x with + | App (c, l) -> + (match kind_of_term c with + Construct c -> + if c = Term.destConstruct (Lazy.force sig_).intro + then Some (l.(0), l.(1), l.(2), l.(3)) + else None + | _ -> None) + | _ -> None + module Coercion = struct - + exception NoSubtacCoercion - - let rec disc_subset x = - match kind_of_term x with - | App (c, l) -> - (match kind_of_term c with - Ind i -> - let len = Array.length l in - let sig_ = Lazy.force sig_ in - if len = 2 && i = Term.destInd sig_.typ - then - let (a, b) = pair_of_array l in - Some (a, b) - else None - | _ -> None) - | _ -> None - - and disc_exist env x = - match kind_of_term x with - | App (c, l) -> - (match kind_of_term c with - Construct c -> - if c = Term.destConstruct (Lazy.force sig_).intro - then Some (l.(0), l.(1), l.(2), l.(3)) - else None - | _ -> None) - | _ -> None - - + let disc_proj_exist env x = match kind_of_term x with | App (c, l) -> diff --git a/contrib/subtac/subtac_coercion.mli b/contrib/subtac/subtac_coercion.mli index 53a8d213..5678c10e 100644 --- a/contrib/subtac/subtac_coercion.mli +++ b/contrib/subtac/subtac_coercion.mli @@ -1 +1,4 @@ +open Term +val disc_subset : types -> (types * types) option + module Coercion : Coercion.S diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml index a2f54b02..4876b065 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -99,7 +99,7 @@ let interp_binder sigma env na t = SPretyping.pretype_gen sigma env ([], []) IsType (locate_if_isevar (loc_of_rawconstr t) na t) let interp_context_evars evdref env params = - let bl = Constrintern.intern_context (Evd.evars_of !evdref) env params in + let bl = Constrintern.intern_context false (Evd.evars_of !evdref) env params in let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> @@ -284,7 +284,7 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = mkApp (constr_of_global (Lazy.force fix_sub_ref), [| argtyp ; wf_rel ; - make_existential dummy_loc ~opaque:false env isevars wf_proof ; + make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; lift lift_cst prop ; lift lift_cst intern_body_lam |]) | Some f -> @@ -385,7 +385,7 @@ let interp_recursive fixkind l boxed = let env_rec = push_named_context rec_sign env in (* Get interpretation metadatas *) - let impls = Command.compute_interning_datas env [] fixnames fixtypes fiximps in + let impls = Command.compute_interning_datas env Constrintern.Recursive [] fixnames fixtypes fiximps in let notations = List.fold_right Option.List.cons ntnl [] in (* Interp bodies with rollback because temp use of notations/implicit *) diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml index a393e2c9..cc1e2dde 100644 --- a/contrib/subtac/subtac_obligations.ml +++ b/contrib/subtac/subtac_obligations.ml @@ -1,7 +1,9 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) open Printf open Pp open Subtac_utils open Command +open Environ open Term open Names @@ -13,9 +15,11 @@ open Decl_kinds open Util open Evd open Declare +open Proof_type type definition_hook = global_reference -> unit +let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) let pperror cmd = Util.errorlabstrm "Program" cmd let error s = pperror (str s) @@ -25,15 +29,17 @@ let explain_no_obligations = function Some ident -> str "No obligations for program " ++ str (string_of_id ident) | None -> str "No obligations remaining" -type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array - +type obligation_info = (Names.identifier * Term.types * loc * obligation_definition_status * Intset.t + * Tacexpr.raw_tactic_expr option) array + type obligation = { obl_name : identifier; obl_type : types; obl_location : loc; obl_body : constr option; - obl_opaque : bool; + obl_status : obligation_definition_status; obl_deps : Intset.t; + obl_tac : Tacexpr.raw_tactic_expr option; } type obligations = (obligation array * int) @@ -79,22 +85,29 @@ let _ = let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type -let subst_deps obls deps t = - Intset.fold - (fun x acc -> - let xobl = obls.(x) in - debug 3 (str "Trying to get body of obligation " ++ int x); - let oblb = - try Option.get xobl.obl_body - with _ -> - debug 3 (str "Couldn't get body of obligation " ++ int x); - assert(false) - in - Term.subst1 oblb (Term.subst_var xobl.obl_name acc)) - deps t - +let get_obligation_body expand obl = + let c = Option.get obl.obl_body in + if expand && obl.obl_status = Expand then + match kind_of_term c with + | Const c -> constant_value (Global.env ()) c + | _ -> c + else c + +let subst_deps expand obls deps t = + let subst = + Intset.fold + (fun x acc -> + let xobl = obls.(x) in + let oblb = + try get_obligation_body expand xobl + with _ -> assert(false) + in (xobl.obl_name, oblb) :: acc) + deps [] + in(* Termops.it_mkNamedProd_or_LetIn t subst *) + Term.replace_vars subst t + let subst_deps_obl obls obl = - let t' = subst_deps obls obl.obl_deps obl.obl_type in + let t' = subst_deps false obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } module ProgMap = Map.Make(struct type t = identifier let compare = compare end) @@ -150,14 +163,14 @@ let rec intset_to = function -1 -> Intset.empty | n -> Intset.add n (intset_to (pred n)) -let subst_body prg = +let subst_body expand prg = let obls, _ = prg.prg_obligations in let ints = intset_to (pred (Array.length obls)) in - subst_deps obls ints prg.prg_body, - subst_deps obls ints (Termops.refresh_universes prg.prg_type) + subst_deps expand obls ints prg.prg_body, + subst_deps expand obls ints (Termops.refresh_universes prg.prg_type) let declare_definition prg = - let body, typ = subst_body prg in + let body, typ = subst_body false prg in (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ my_print_constr (Global.env()) body ++ str " : " ++ my_print_constr (Global.env()) prg.prg_type); @@ -188,7 +201,7 @@ let declare_definition prg = in let gr = ConstRef c in if Impargs.is_implicit_args () || prg.prg_implicits <> [] then - Impargs.declare_manual_implicits false gr (Impargs.is_implicit_args ()) prg.prg_implicits; + Impargs.declare_manual_implicits false gr prg.prg_implicits; print_message (Subtac_utils.definition_message prg.prg_name); prg.prg_hook gr; gr @@ -216,14 +229,18 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = let ctx = fst (Sign.decompose_prod_n_assum m fixtype) in list_map_i (fun i _ -> i) 0 ctx +let reduce_fix = + Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty + let declare_mutual_definition l = let len = List.length l in let fixdefs, fixtypes, fiximps = list_split3 (List.map (fun x -> - let subs, typ = (subst_body x) in + let subs, typ = (subst_body false x) in snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l) in +(* let fixdefs = List.map reduce_fix fixdefs in *) let fixkind = Option.get (List.hd l).prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in @@ -248,41 +265,33 @@ let declare_mutual_definition l = (match List.hd kns with ConstRef kn -> kn | _ -> assert false) let declare_obligation obl body = - let ce = - { const_entry_body = body; - const_entry_type = Some obl.obl_type; - const_entry_opaque = if get_proofs_transparency () then false else obl.obl_opaque; - const_entry_boxed = false} - in - let constant = Declare.declare_constant obl.obl_name - (DefinitionEntry ce,IsProof Property) - in - print_message (Subtac_utils.definition_message obl.obl_name); - { obl with obl_body = Some (mkConst constant) } - -let try_tactics obls = - Array.map - (fun obl -> - match obl.obl_body with - None -> - (try - let ev = evar_of_obligation obl in - let c = Subtac_utils.solve_by_tac ev Auto.default_full_auto in - declare_obligation obl c - with _ -> obl) - | _ -> obl) - obls - + match obl.obl_status with + | Expand -> { obl with obl_body = Some body } + | Define opaque -> + let ce = + { const_entry_body = body; + const_entry_type = Some obl.obl_type; + const_entry_opaque = + (if get_proofs_transparency () then false + else opaque) ; + const_entry_boxed = false} + in + let constant = Declare.declare_constant obl.obl_name + (DefinitionEntry ce,IsProof Property) + in + print_message (Subtac_utils.definition_message obl.obl_name); + { obl with obl_body = Some (mkConst constant) } + let red = Reductionops.nf_betaiota let init_prog_info n b t deps fixkind notations obls impls kind hook = let obls' = Array.mapi - (fun i (n, t, l, o, d) -> + (fun i (n, t, l, o, d, tac) -> debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); { obl_name = n ; obl_body = None; - obl_location = l; obl_type = red t; obl_opaque = o; - obl_deps = d }) + obl_location = l; obl_type = red t; obl_status = o; + obl_deps = d; obl_tac = tac }) obls in { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); @@ -369,22 +378,16 @@ let has_dependencies obls n = !res let kind_of_opacity o = - if o then Subtac_utils.goal_proof_kind - else Subtac_utils.goal_kind - -let obligations_of_evars evars = - let arr = - Array.of_list - (List.map - (fun (n, t) -> - { obl_name = n; - obl_type = t; - obl_location = dummy_loc; - obl_body = None; - obl_opaque = false; - obl_deps = Intset.empty; - }) evars) - in arr, Array.length arr + match o with + | Define false | Expand -> Subtac_utils.goal_kind + | _ -> Subtac_utils.goal_proof_kind + +let not_transp_msg = + str "Obligation should be transparent but was declared opaque." ++ spc () ++ + str"Use 'Defined' instead." + +let warn_not_transp () = ppwarn not_transp_msg +let error_not_transp () = pperror not_transp_msg let rec solve_obligation prg num = let user_num = succ num in @@ -394,26 +397,37 @@ let rec solve_obligation prg num = pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") else match deps_remaining obls obl.obl_deps with - [] -> - let obl = subst_deps_obl obls obl in - Command.start_proof obl.obl_name (kind_of_opacity obl.obl_opaque) obl.obl_type - (fun strength gr -> - debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished"); - let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - match update_obls prg obls (pred rem) with - | Remain n when n > 0 -> - if has_dependencies obls num then - ignore(auto_solve_obligations (Some prg.prg_name)) - | _ -> ()); - trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ - Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); - Pfedit.by !default_tactic; - Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () - | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " - ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) - + | [] -> + let obl = subst_deps_obl obls obl in + Command.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type + (fun strength gr -> + let cst = match gr with ConstRef cst -> cst | _ -> assert false in + let obl = + let transparent = evaluable_constant cst (Global.env ()) in + let body = + match obl.obl_status with + | Expand -> + if not transparent then error_not_transp () + else constant_value (Global.env ()) cst + | Define opaque -> + if not opaque && not transparent then error_not_transp () + else Libnames.constr_of_global gr + in { obl with obl_body = Some body } + in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + match update_obls prg obls (pred rem) with + | Remain n when n > 0 -> + if has_dependencies obls num then + ignore(auto_solve_obligations (Some prg.prg_name) None) + | _ -> ()); + trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ + Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); + Pfedit.by !default_tactic; + Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () + | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) + and subtac_obligation (user_num, name, typ) = let num = pred user_num in let prg = get_prog_err name in @@ -434,12 +448,17 @@ and solve_obligation_by_tac prg obls i tac = (try if deps_remaining obls obl.obl_deps = [] then let obl = subst_deps_obl obls obl in + let tac = + match tac with + | Some t -> t + | None -> + match obl.obl_tac with + | Some t -> Tacinterp.interp t + | None -> !default_tactic + in let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in - if obl.obl_opaque then - obls.(i) <- declare_obligation obl t - else - obls.(i) <- { obl with obl_body = Some t }; - true + obls.(i) <- declare_obligation obl t; + true else false with | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) @@ -473,34 +492,40 @@ and try_solve_obligation n prg tac = let obls' = Array.copy obls in if solve_obligation_by_tac prg obls' n tac then ignore(update_obls prg obls' (pred rem)); - + and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () -and auto_solve_obligations n : progress = +and auto_solve_obligations n tac : progress = Flags.if_verbose msgnl (str "Solving obligations automatically..."); - try solve_obligations n !default_tactic with NoObligations _ -> Dependent + try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent open Pp let show_obligations ?(msg=true) n = let prg = get_prog_err n in let n = prg.prg_name in let obls, rem = prg.prg_obligations in + let showed = ref 5 in if msg then msgnl (int rem ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> match x.obl_body with - None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ - my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()) - | Some _ -> ()) + | None -> + if !showed > 0 then ( + decr showed; + msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ + str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()))) + | Some _ -> ()) obls - + let show_term n = let prg = get_prog_err n in let n = prg.prg_name in - msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () + msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ + my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ my_print_constr (Global.env ()) prg.prg_body) -let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?(hook=fun x -> ()) obls = +let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun x -> ()) obls = Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); let prg = init_prog_info n b t [] None [] obls implicits kind hook in let obls,_ = prg.prg_obligations in @@ -513,12 +538,12 @@ let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?(hook= let len = Array.length obls in let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in from_prg := ProgMap.add n prg !from_prg; - let res = auto_solve_obligations (Some n) in + let res = auto_solve_obligations (Some n) tactic in match res with - | Remain rem when rem < 5 -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res - | _ -> res) + | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res + | _ -> res) -let add_mutual_definitions l ?(kind=Global,false,Definition) notations fixkind = +let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in let upd = List.fold_left (fun acc (n, b, t, imps, obls) -> @@ -531,8 +556,9 @@ let add_mutual_definitions l ?(kind=Global,false,Definition) notations fixkind = List.fold_left (fun finished x -> if finished then finished else - match auto_solve_obligations (Some x) with - Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true + let res = auto_solve_obligations (Some x) tactic in + match res with + | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true | _ -> false) false deps in () @@ -562,8 +588,8 @@ let next_obligation n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in let i = - array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) - obls + try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls + with Not_found -> anomaly "Could not find a solvable obligation." in solve_obligation prg i let default_tactic () = !default_tactic diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli index 6d13e3bd..60c0a413 100644 --- a/contrib/subtac/subtac_obligations.mli +++ b/contrib/subtac/subtac_obligations.mli @@ -1,9 +1,14 @@ open Names open Util open Libnames +open Evd +open Proof_type -type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array - (* ident, type, location, opaque or transparent, dependencies *) +type obligation_info = + (identifier * Term.types * loc * + obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array + (* ident, type, location, (opaque or transparent, expand or define), + dependencies, tactic to solve it *) type progress = (* Resolution status of a program *) | Remain of int (* n obligations remaining *) @@ -21,6 +26,7 @@ type definition_hook = global_reference -> unit val add_definition : Names.identifier -> Term.constr -> Term.types -> ?implicits:(Topconstr.explicitation * (bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> + ?tactic:Proof_type.tactic -> ?hook:definition_hook -> obligation_info -> progress type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list @@ -28,6 +34,7 @@ type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) val add_mutual_definitions : (Names.identifier * Term.constr * Term.types * (Topconstr.explicitation * (bool * bool)) list * obligation_info) list -> + ?tactic:Proof_type.tactic -> ?kind:Decl_kinds.definition_kind -> notations -> Command.fixpoint_kind -> unit @@ -36,14 +43,14 @@ val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr op val next_obligation : Names.identifier option -> unit -val solve_obligations : Names.identifier option -> Proof_type.tactic -> progress +val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress (* Number of remaining obligations to be solved for this program *) -val solve_all_obligations : Proof_type.tactic -> unit +val solve_all_obligations : Proof_type.tactic option -> unit -val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic -> unit +val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit -val try_solve_obligations : Names.identifier option -> Proof_type.tactic -> unit +val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit val show_obligations : ?msg:bool -> Names.identifier option -> unit diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml index ad76bdeb..07a75720 100644 --- a/contrib/subtac/subtac_pretyping.ml +++ b/contrib/subtac/subtac_pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: subtac_pretyping.ml 11574 2008-11-10 13:45:05Z msozeau $ *) open Global open Pp @@ -73,7 +73,7 @@ let interp env isevars c tycon = let _ = isevars := Evarutil.nf_evar_defs !isevars in let evd,_ = consider_remaining_unif_problems env !isevars in (* let unevd = undefined_evars evd in *) - let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env evd in + let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in let evm = evars_of unevd' in isevars := unevd'; nf_evar evm j.uj_val, nf_evar evm j.uj_type diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml index 559b6ac1..00d37f35 100644 --- a/contrib/subtac/subtac_pretyping_F.ml +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping_F.ml 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: subtac_pretyping_F.ml 11576 2008-11-10 19:13:15Z msozeau $ *) open Pp open Util @@ -276,14 +276,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RApp (loc,f,args) -> let length = List.length args in - let ftycon = - if length > 0 then - match tycon with - | None -> None - | Some (None, ty) -> mk_abstr_tycon length ty - | Some (Some (init, cur), ty) -> - Some (Some (length + init, length + cur), ty) - else tycon + let ftycon = + let ty = + if length > 0 then + match tycon with + | None -> None + | Some (None, ty) -> mk_abstr_tycon length ty + | Some (Some (init, cur), ty) -> + Some (Some (length + init, length + cur), ty) + else tycon + in + match ty with + | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty + | _ -> None in let fj = pretype ftycon env isevars lvar f in let floc = loc_of_rawconstr f in diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index bae2731a..cdbc4023 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -159,7 +159,7 @@ let app_opt c e = let print_args env args = Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") -let make_existential loc ?(opaque = true) env isevars c = +let make_existential loc ?(opaque = Define true) env isevars c = let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in let (key, args) = destEvar evar in (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ @@ -232,7 +232,7 @@ let build_dependent_sum l = trace (spc () ++ str ("treating evar " ^ string_of_id n)); (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) with _ -> ()); - let tac = assert_tac true (Name n) hyptype in + let tac = assert_tac (Name n) hyptype in let conttac = (fun cont -> conttac @@ -369,7 +369,7 @@ let solve_by_tac evi t = Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl (fun _ _ -> ()); Pfedit.by (tclCOMPLETE t); - let _,(const,_,_) = Pfedit.cook_proof ignore in + let _,(const,_,_,_) = Pfedit.cook_proof ignore in Pfedit.delete_current_proof (); const.Entries.const_entry_body with e -> Pfedit.delete_current_proof(); @@ -470,4 +470,3 @@ let tactics_tac s = let tactics_call tac args = TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) - diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index 49335211..964f668f 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -83,7 +83,8 @@ val wf_relations : (constr, constr lazy_t) Hashtbl.t type binders = local_binder list val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds -val make_existential : loc -> ?opaque:bool -> env -> evar_defs ref -> types -> constr +val make_existential : loc -> ?opaque:obligation_definition_status -> + env -> evar_defs ref -> types -> constr val make_existential_expr : loc -> 'a -> 'b -> constr_expr val string_of_hole_kind : hole_kind -> string val evars_of_term : evar_map -> evar_map -> constr -> evar_map diff --git a/contrib/xml/cic2Xml.ml b/contrib/xml/cic2Xml.ml index f04a03f9..08d3a850 100644 --- a/contrib/xml/cic2Xml.ml +++ b/contrib/xml/cic2Xml.ml @@ -7,7 +7,7 @@ let print_xml_term ch env sigma cic = let seed = ref 0 in let acic = Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids - ids_to_father_ids ids_to_inner_sorts ids_to_inner_types [] + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types env [] sigma (Unshare.unshare cic) None in let xml = Acic2Xml.print_term ids_to_inner_sorts acic in Xml.pp_ch xml ch diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml index 1a6cb9c8..c62db00b 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -349,7 +349,7 @@ let source_id_of_id id = "#source#" ^ id;; let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - pvars ?(fake_dependent_products=false) env idrefs evar_map t expectedty + ?(fake_dependent_products=false) env idrefs evar_map t expectedty = let module D = DoubleTypeInference in let module E = Environ in @@ -541,6 +541,8 @@ print_endline "PASSATO" ; flush stdout ; add_inner_type fresh_id'' ; A.ARel (fresh_id'', n, List.nth idrefs (n-1), id) | T.Var id -> + let pvars = Termops.ids_of_named_context (E.named_context env) in + let pvars = List.map N.string_of_id pvars in let path = get_uri_of_var (N.string_of_id id) pvars in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort && expected_available then @@ -827,6 +829,7 @@ print_endline "PASSATO" ; flush stdout ; aux computeinnertypes None [] env idrefs t ;; +(* Obsolete [HH 1/2009] let acic_of_cic_context metasenv context t = let ids_to_terms = Hashtbl.create 503 in let constr_to_ids = Acic.CicHash.create 503 in @@ -838,8 +841,9 @@ let acic_of_cic_context metasenv context t = ids_to_inner_sorts ids_to_inner_types metasenv context t, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types ;; +*) -let acic_object_of_cic_object pvars sigma obj = +let acic_object_of_cic_object sigma obj = let module A = Acic in let ids_to_terms = Hashtbl.create 503 in let constr_to_ids = Acic.CicHash.create 503 in @@ -853,7 +857,7 @@ let acic_object_of_cic_object pvars sigma obj = let seed = ref 0 in let acic_term_of_cic_term_context' = acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types pvars in + ids_to_inner_sorts ids_to_inner_types in (*CSC: is this the right env to use? Hhmmm. There is a problem: in *) (*CSC: Global.env () the object we are exporting is already defined, *) (*CSC: either in the environment or in the named context (in the case *) diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 index 05be01bc..a501fb6a 100644 --- a/contrib/xml/proofTree2Xml.ml4 +++ b/contrib/xml/proofTree2Xml.ml4 @@ -31,7 +31,6 @@ let constr_to_xml obj sigma env = let ids_to_inner_sorts = Hashtbl.create 503 in let ids_to_inner_types = Hashtbl.create 503 in - let pvars = [] in (* named_context holds section variables and local variables *) let named_context = Environ.named_context env in (* real_named_context holds only the section variables *) @@ -54,7 +53,7 @@ let constr_to_xml obj sigma env = try let annobj = Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids - ids_to_father_ids ids_to_inner_sorts ids_to_inner_types pvars rel_env + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env idrefs sigma (Unshare.unshare obj') None in Acic2Xml.print_term ids_to_inner_sorts annobj @@ -91,6 +90,7 @@ let string_of_prim_rule x = match x with | Proof_type.Thin _ -> "Thin" | Proof_type.ThinBody _-> "ThinBody" | Proof_type.Move (_,_,_) -> "Move" + | Proof_type.Order _ -> "Order" | Proof_type.Rename (_,_) -> "Rename" | Proof_type.Change_evars -> "Change_evars" diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 3c4b01f5..1ae18661 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -79,15 +79,6 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *) | _ -> false (* uninteresting thing that won't be printed*) ;; - -(* A SIMPLE DATA STRUCTURE AND SOME FUNCTIONS TO MANAGE THE CURRENT *) -(* ENVIRONMENT (= [(name1,l1); ...;(namen,ln)] WHERE li IS THE LIST *) -(* OF VARIABLES DECLARED IN THE i-th SUPER-SECTION OF THE CURRENT *) -(* SECTION, WHOSE PATH IS namei *) - -let pvars = ref ([] : string list);; -let cumenv = ref Environ.empty_env;; - (* filter_params pvars hyps *) (* filters out from pvars (which is a list of lists) all the variables *) (* that does not belong to hyps (which is a simple list) *) @@ -120,22 +111,6 @@ type variables_type = | Assumption of string * Term.constr ;; -let add_to_pvars x = - let module E = Environ in - let v = - match x with - Definition (v, bod, typ) -> - cumenv := - E.push_named (Names.id_of_string v, Some bod, typ) !cumenv ; - v - | Assumption (v, typ) -> - cumenv := - E.push_named (Names.id_of_string v, None, typ) !cumenv ; - v - in - pvars := v::!pvars -;; - (* The computation is very inefficient, but we can't do anything *) (* better unless this function is reimplemented in the Declare *) (* module. *) @@ -231,7 +206,7 @@ let print_object uri obj sigma proof_tree_infos filename = ignore (Unix.system ("gzip " ^ fn' ^ ".xml")) in let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) = - Cic2acic.acic_object_of_cic_object !pvars sigma obj in + Cic2acic.acic_object_of_cic_object sigma obj in let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in let xmltypes = Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in @@ -691,7 +666,7 @@ let _ = end ; Option.iter (fun fn -> - let coqdoc = Coq_config.bindir^"/coqdoc" in + let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in let options = " --html -s --body-only --no-index --latin1 --raw-comments" in let dir = Option.get xml_library_root in let command cmd = -- cgit v1.2.3