summaryrefslogtreecommitdiff
path: root/contrib
diff options
context:
space:
mode:
Diffstat (limited to 'contrib')
-rw-r--r--contrib/cc/cctac.ml27
-rw-r--r--contrib/dp/dp_gappa.ml6
-rw-r--r--contrib/dp/dp_zenon.mll4
-rw-r--r--contrib/extraction/common.ml610
-rw-r--r--contrib/extraction/common.mli20
-rw-r--r--contrib/extraction/extract_env.ml287
-rw-r--r--contrib/extraction/extraction.ml26
-rw-r--r--contrib/extraction/g_extraction.ml423
-rw-r--r--contrib/extraction/haskell.ml9
-rw-r--r--contrib/extraction/modutil.ml76
-rw-r--r--contrib/extraction/modutil.mli16
-rw-r--r--contrib/extraction/ocaml.ml142
-rw-r--r--contrib/extraction/scheme.ml4
-rw-r--r--contrib/extraction/table.ml158
-rw-r--r--contrib/extraction/table.mli14
-rw-r--r--contrib/firstorder/rules.ml4
-rw-r--r--contrib/fourier/Fourier.v8
-rw-r--r--contrib/fourier/fourier.ml4
-rw-r--r--contrib/funind/functional_principles_proofs.ml23
-rw-r--r--contrib/funind/functional_principles_types.ml32
-rw-r--r--contrib/funind/g_indfun.ml4125
-rw-r--r--contrib/funind/indfun.ml4
-rw-r--r--contrib/funind/indfun_common.ml7
-rw-r--r--contrib/funind/invfun.ml8
-rw-r--r--contrib/funind/merge.ml4
-rw-r--r--contrib/funind/rawterm_to_relation.ml16
-rw-r--r--contrib/funind/recdef.ml8
-rw-r--r--contrib/interface/ascent.mli2
-rw-r--r--contrib/interface/blast.ml28
-rw-r--r--contrib/interface/centaur.ml422
-rw-r--r--contrib/interface/dad.ml2
-rw-r--r--contrib/interface/depends.ml6
-rw-r--r--contrib/interface/name_to_ast.ml8
-rw-r--r--contrib/interface/parse.ml4
-rw-r--r--contrib/interface/paths.ml2
-rw-r--r--contrib/interface/pbp.ml2
-rw-r--r--contrib/interface/showproof.ml3
-rw-r--r--contrib/interface/vtp.ml2
-rw-r--r--contrib/interface/xlate.ml114
-rw-r--r--contrib/jprover/README76
-rw-r--r--contrib/jprover/jall.ml4599
-rw-r--r--contrib/jprover/jall.mli339
-rw-r--r--contrib/jprover/jlogic.ml106
-rw-r--r--contrib/jprover/jlogic.mli40
-rw-r--r--contrib/jprover/jprover.ml4554
-rw-r--r--contrib/jprover/jterm.ml872
-rw-r--r--contrib/jprover/jterm.mli110
-rw-r--r--contrib/jprover/jtunify.ml507
-rw-r--r--contrib/jprover/jtunify.mli35
-rw-r--r--contrib/jprover/opname.ml90
-rw-r--r--contrib/jprover/opname.mli15
-rw-r--r--contrib/micromega/coq_micromega.ml2
-rw-r--r--contrib/omega/OmegaLemmas.v43
-rw-r--r--contrib/omega/coq_omega.ml47
-rw-r--r--contrib/ring/ring.ml28
-rw-r--r--contrib/setoid_ring/Ring_base.v1
-rw-r--r--contrib/setoid_ring/Ring_tac.v1
-rw-r--r--contrib/setoid_ring/newring.ml411
-rw-r--r--contrib/subtac/equations.ml41149
-rw-r--r--contrib/subtac/eterm.ml121
-rw-r--r--contrib/subtac/eterm.mli22
-rw-r--r--contrib/subtac/g_subtac.ml416
-rw-r--r--contrib/subtac/subtac.ml38
-rw-r--r--contrib/subtac/subtac_cases.ml4
-rw-r--r--contrib/subtac/subtac_classes.ml159
-rw-r--r--contrib/subtac/subtac_classes.mli10
-rw-r--r--contrib/subtac/subtac_coercion.ml59
-rw-r--r--contrib/subtac/subtac_coercion.mli3
-rw-r--r--contrib/subtac/subtac_command.ml6
-rw-r--r--contrib/subtac/subtac_obligations.ml246
-rw-r--r--contrib/subtac/subtac_obligations.mli19
-rw-r--r--contrib/subtac/subtac_pretyping.ml4
-rw-r--r--contrib/subtac/subtac_pretyping_F.ml23
-rw-r--r--contrib/subtac/subtac_utils.ml7
-rw-r--r--contrib/subtac/subtac_utils.mli3
-rw-r--r--contrib/xml/cic2Xml.ml2
-rw-r--r--contrib/xml/cic2acic.ml10
-rw-r--r--contrib/xml/proofTree2Xml.ml44
-rw-r--r--contrib/xml/xmlcommand.ml29
79 files changed, 2660 insertions, 8610 deletions
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 [<prefix>.s.<List.rev ls'>].
+ 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 <jall.ml> is located in meta-prl/refiner/reflib of the
-MetaPRL directory. Some parts of this file are modified by Huang.
-
-2. <jtunify.ml> is also located in meta-prl/refiner/reflib with no modification.
-
-3. <jlogic.ml> is modified from meta-prl/refiner/reflib/jlogic_sig.mlz.
-
-4. <jterm.ml> and <opname.ml> 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 <schmitts@spmail.slu.edu>
- * Modified by: Aleksey Nogin <nogin@cs.cornell.edu>
- *)
-
-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=<abstr>; ";
- 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=[<abstr>]";
- 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 <schmitts@spmail.slu.edu>
- * Modified by: Aleksey Nogin <nogin@cs.cornell.edu>
- *)
-
-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 *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4use: "pa_extend.cmo" i*)
+
+(* $Id: subtac_cases.ml 11198 2008-07-01 17:03:43Z msozeau $ *)
+
+open Cases
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Inductiveops
+open Environ
+open Sign
+open Reductionops
+open Typeops
+open Type_errors
+
+open Rawterm
+open Retyping
+open Pretype_errors
+open Evarutil
+open Evarconv
+open List
+open Libnames
+
+type pat =
+ | PRel of int
+ | PCstr of constructor * pat list
+ | PInac of constr
+
+let coq_inacc = lazy (Coqlib.gen_constant "equations" ["Program";"Equality"] "inaccessible_pattern")
+
+let mkInac env c =
+ mkApp (Lazy.force coq_inacc, [| Typing.type_of env Evd.empty c ; c |])
+
+let rec constr_of_pat ?(inacc=true) env = function
+ | PRel i -> 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 =