X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fparamodulation%2Fsaturation.ml;h=c933aec0b48c3c11115d8d8346302f1144c93892;hb=12cc5b2b8e7f7bb0b5e315094b008a293a4df6b1;hp=4c1480d100c86a72a88ee652de5d4dcd5d697a69;hpb=c76c8c83852508d69e7765dc9e929cdcf34af57d;p=helm.git diff --git a/helm/ocaml/paramodulation/saturation.ml b/helm/ocaml/paramodulation/saturation.ml index 4c1480d10..c933aec0b 100644 --- a/helm/ocaml/paramodulation/saturation.ml +++ b/helm/ocaml/paramodulation/saturation.ml @@ -1,17 +1,40 @@ open Inference;; open Utils;; -type result = - | Failure - | Success of Cic.term option * environment -;; +(* profiling statistics... *) +let infer_time = ref 0.;; +let forward_simpl_time = ref 0.;; +let forward_simpl_new_time = ref 0.;; +let backward_simpl_time = ref 0.;; +let passive_maintainance_time = ref 0.;; + +(* limited-resource-strategy related globals *) +let processed_clauses = ref 0;; (* number of equalities selected so far... *) +let time_limit = ref 0.;; (* in seconds, settable by the user... *) +let start_time = ref 0.;; (* time at which the execution started *) +let elapsed_time = ref 0.;; +(* let maximal_weight = ref None;; *) +let maximal_retained_equality = ref None;; + +(* equality-selection related globals *) +let use_fullred = ref false;; +let weight_age_ratio = ref 0;; (* settable by the user from the command line *) +let weight_age_counter = ref !weight_age_ratio;; +let symbols_ratio = ref 0;; +let symbols_counter = ref 0;; -type equality_sign = Negative | Positive;; +(* statistics... *) +let derived_clauses = ref 0;; +let kept_clauses = ref 0;; -let string_of_sign = function - | Negative -> "Negative" - | Positive -> "Positive" +(* index of the greatest Cic.Meta created - TODO: find a better way! *) +let maxmeta = ref 0;; + + +type result = + | Failure + | Success of Inference.equality option * environment ;; @@ -21,7 +44,7 @@ let symbols_of_equality (_, (_, left, right), _, _) = ;; *) -let symbols_of_equality ((_, (_, left, right), _, _) as equality) = +let symbols_of_equality ((_, _, (_, left, right, _), _, _) as equality) = let m1 = symbols_of_term left in let m = TermMap.fold @@ -41,38 +64,44 @@ let symbols_of_equality ((_, (_, left, right), _, _) as equality) = ;; -module OrderedEquality = -struct +module OrderedEquality = struct type t = Inference.equality let compare eq1 eq2 = match meta_convertibility_eq eq1 eq2 with | true -> 0 | false -> - let _, (ty, left, right), _, _ = eq1 - and _, (ty', left', right'), _, _ = eq2 in - let weight_of t = fst (weight_of_term ~consider_metas:false t) in - let w1 = (weight_of ty) + (weight_of left) + (weight_of right) - and w2 = (weight_of ty') + (weight_of left') + (weight_of right') in + let w1, _, (ty, left, right, _), _, a = eq1 + and w2, _, (ty', left', right', _), _, a' = eq2 in +(* let weight_of t = fst (weight_of_term ~consider_metas:false t) in *) +(* let w1 = (weight_of ty) + (weight_of left) + (weight_of right) *) +(* and w2 = (weight_of ty') + (weight_of left') + (weight_of right') in *) match Pervasives.compare w1 w2 with - | 0 -> Pervasives.compare eq1 eq2 + | 0 -> + let res = (List.length a) - (List.length a') in + if res <> 0 then res else ( + try + let res = Pervasives.compare (List.hd a) (List.hd a') in + if res <> 0 then res else Pervasives.compare eq1 eq2 + with _ -> Pervasives.compare eq1 eq2 +(* match a, a' with *) +(* | (Cic.Meta (i, _)::_), (Cic.Meta (j, _)::_) -> *) +(* let res = Pervasives.compare i j in *) +(* if res <> 0 then res else Pervasives.compare eq1 eq2 *) +(* | _, _ -> Pervasives.compare eq1 eq2 *) + ) | res -> res end module EqualitySet = Set.Make(OrderedEquality);; -let weight_age_ratio = ref 0;; (* settable by the user from the command line *) -let weight_age_counter = ref !weight_age_ratio;; - -let symbols_ratio = ref 0;; -let symbols_counter = ref 0;; - - -let select env passive active = - let (neg_list, neg_set), (pos_list, pos_set) = passive in +let select env passive (active, _) = + processed_clauses := !processed_clauses + 1; + + let (neg_list, neg_set), (pos_list, pos_set), passive_table = passive in let remove eq l = - List.filter (fun e -> not (e = eq)) l + List.filter (fun e -> e <> eq) l in if !weight_age_ratio > 0 then weight_age_counter := !weight_age_counter - 1; @@ -81,9 +110,17 @@ let select env passive active = weight_age_counter := !weight_age_ratio; match neg_list, pos_list with | hd::tl, pos -> - (Negative, hd), ((tl, EqualitySet.remove hd neg_set), (pos, pos_set)) + (* Negatives aren't indexed, no need to remove them... *) + (Negative, hd), + ((tl, EqualitySet.remove hd neg_set), (pos, pos_set), passive_table) | [], hd::tl -> - (Positive, hd), (([], neg_set), (tl, EqualitySet.remove hd pos_set)) + let passive_table = + Indexing.remove_index passive_table hd +(* if !use_fullred then Indexing.remove_index passive_table hd *) +(* else passive_table *) + in + (Positive, hd), + (([], neg_set), (tl, EqualitySet.remove hd pos_set), passive_table) | _, _ -> assert false ) | _ when (!symbols_counter > 0) && (EqualitySet.is_empty neg_set) -> ( @@ -95,52 +132,57 @@ let select env passive active = | (Negative, e)::_ -> let symbols = symbols_of_equality e in let card = cardinality symbols in + let foldfun k v (r1, r2) = + if TermMap.mem k symbols then + let c = TermMap.find k symbols in + let c1 = abs (c - v) in + let c2 = v - c1 in + r1 + c2, r2 + c1 + else + r1, r2 + v + in let f equality (i, e) = let common, others = - TermMap.fold - (fun k v (r1, r2) -> - if TermMap.mem k symbols then - let c = TermMap.find k symbols in - let c1 = abs (c - v) in - let c2 = v - c1 in - r1 + c2, r2 + c1 - else - r1, r2 + v) - (symbols_of_equality equality) (0, 0) + TermMap.fold foldfun (symbols_of_equality equality) (0, 0) in -(* Printf.printf "equality: %s, common: %d, others: %d\n" *) -(* (string_of_equality ~env equality) common others; *) let c = others + (abs (common - card)) in if c < i then (c, equality) +(* else if c = i then *) +(* match OrderedEquality.compare equality e with *) +(* | -1 -> (c, equality) *) +(* | res -> (i, e) *) else (i, e) in let e1 = EqualitySet.min_elt pos_set in let initial = let common, others = - TermMap.fold - (fun k v (r1, r2) -> - if TermMap.mem k symbols then - let c = TermMap.find k symbols in - let c1 = abs (c - v) in - let c2 = v - (abs (c - v)) in - r1 + c1, r2 + c2 - else - r1, r2 + v) - (symbols_of_equality e1) (0, 0) + TermMap.fold foldfun (symbols_of_equality e1) (0, 0) in (others + (abs (common - card))), e1 in let _, current = EqualitySet.fold f pos_set initial in (* Printf.printf "\nsymbols-based selection: %s\n\n" *) (* (string_of_equality ~env current); *) + let passive_table = + Indexing.remove_index passive_table current +(* if !use_fullred then Indexing.remove_index passive_table current *) +(* else passive_table *) + in (Positive, current), (([], neg_set), - (remove current pos_list, EqualitySet.remove current pos_set)) + (remove current pos_list, EqualitySet.remove current pos_set), + passive_table) | _ -> - let current = EqualitySet.min_elt pos_set in + let current = EqualitySet.min_elt pos_set in + let passive_table = + Indexing.remove_index passive_table current +(* if !use_fullred then Indexing.remove_index passive_table current *) +(* else passive_table *) + in let passive = (neg_list, neg_set), - (remove current pos_list, EqualitySet.remove current pos_set) + (remove current pos_list, EqualitySet.remove current pos_set), + passive_table in (Positive, current), passive ) @@ -151,14 +193,18 @@ let select env passive active = let current = set_selection pos_set in let passive = (neg_list, neg_set), - (remove current pos_list, EqualitySet.remove current pos_set) + (remove current pos_list, EqualitySet.remove current pos_set), + Indexing.remove_index passive_table current +(* if !use_fullred then Indexing.remove_index passive_table current *) +(* else passive_table *) in (Positive, current), passive else let current = set_selection neg_set in let passive = (remove current neg_list, EqualitySet.remove current neg_set), - (pos_list, pos_set) + (pos_list, pos_set), + passive_table in (Negative, current), passive ;; @@ -168,219 +214,449 @@ let make_passive neg pos = let set_of equalities = List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty equalities in - (neg, set_of neg), (pos, set_of pos) + let table = + List.fold_left (fun tbl e -> Indexing.index tbl e) + (Indexing.empty_table ()) pos +(* if !use_fullred then *) +(* List.fold_left (fun tbl e -> Indexing.index tbl e) *) +(* (Indexing.empty_table ()) pos *) +(* else *) +(* Indexing.empty_table () *) + in + (neg, set_of neg), + (pos, set_of pos), + table +;; + + +let make_active () = + [], Indexing.empty_table () ;; let add_to_passive passive (new_neg, new_pos) = - let (neg_list, neg_set), (pos_list, pos_set) = passive in + let (neg_list, neg_set), (pos_list, pos_set), table = passive in let ok set equality = not (EqualitySet.mem equality set) in let neg = List.filter (ok neg_set) new_neg and pos = List.filter (ok pos_set) new_pos in + let table = + List.fold_left (fun tbl e -> Indexing.index tbl e) table pos +(* if !use_fullred then *) +(* List.fold_left (fun tbl e -> Indexing.index tbl e) table pos *) +(* else *) +(* table *) + in let add set equalities = List.fold_left (fun s e -> EqualitySet.add e s) set equalities in - (neg @ neg_list, add neg_set neg), (pos_list @ pos, add pos_set pos) + (neg @ neg_list, add neg_set neg), + (pos_list @ pos, add pos_set pos), + table ;; let passive_is_empty = function - | ([], _), ([], _) -> true + | ([], _), ([], _), _ -> true | _ -> false ;; -(* TODO: find a better way! *) -let maxmeta = ref 0;; +let size_of_passive ((_, ns), (_, ps), _) = + (EqualitySet.cardinal ns) + (EqualitySet.cardinal ps) +;; + + +let size_of_active (active_list, _) = + List.length active_list +;; + -let infer env sign current active = - let rec infer_negative current = function - | [] -> [], [] - | (Negative, _)::tl -> infer_negative current tl - | (Positive, equality)::tl -> - let res = superposition_left env current equality in - let neg, pos = infer_negative current tl in - res @ neg, pos - - and infer_positive current = function - | [] -> [], [] - | (Negative, equality)::tl -> - let res = superposition_left env equality current in - let neg, pos = infer_positive current tl in - res @ neg, pos - | (Positive, equality)::tl -> - let maxm, res = superposition_right !maxmeta env current equality in - let maxm, res' = superposition_right maxm env equality current in +let prune_passive howmany (active, _) passive = + let (nl, ns), (pl, ps), tbl = passive in + let howmany = float_of_int howmany + and ratio = float_of_int !weight_age_ratio in + let in_weight = int_of_float (howmany *. ratio /. (ratio +. 1.)) + and in_age = int_of_float (howmany /. (ratio +. 1.)) in + Printf.printf "in_weight: %d, in_age: %d\n" in_weight in_age; + let symbols, card = + match active with + | (Negative, e)::_ -> + let symbols = symbols_of_equality e in + let card = TermMap.fold (fun k v res -> res + v) symbols 0 in + Some symbols, card + | _ -> None, 0 + in + let counter = ref !symbols_ratio in + let rec pickw w ns ps = + if w > 0 then + if not (EqualitySet.is_empty ns) then + let e = EqualitySet.min_elt ns in + let ns', ps = pickw (w-1) (EqualitySet.remove e ns) ps in + EqualitySet.add e ns', ps + else if !counter > 0 then + let _ = + counter := !counter - 1; + if !counter = 0 then counter := !symbols_ratio + in + match symbols with + | None -> + let e = EqualitySet.min_elt ps in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + | Some symbols -> + let foldfun k v (r1, r2) = + if TermMap.mem k symbols then + let c = TermMap.find k symbols in + let c1 = abs (c - v) in + let c2 = v - c1 in + r1 + c2, r2 + c1 + else + r1, r2 + v + in + let f equality (i, e) = + let common, others = + TermMap.fold foldfun (symbols_of_equality equality) (0, 0) + in + let c = others + (abs (common - card)) in + if c < i then (c, equality) + else (i, e) + in + let e1 = EqualitySet.min_elt ps in + let initial = + let common, others = + TermMap.fold foldfun (symbols_of_equality e1) (0, 0) + in + (others + (abs (common - card))), e1 + in + let _, e = EqualitySet.fold f ps initial in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + else + let e = EqualitySet.min_elt ps in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + else + EqualitySet.empty, EqualitySet.empty + in +(* let in_weight, ns = pickw in_weight ns in *) +(* let _, ps = pickw in_weight ps in *) + let ns, ps = pickw in_weight ns ps in + let rec picka w s l = + if w > 0 then + match l with + | [] -> w, s, [] + | hd::tl when not (EqualitySet.mem hd s) -> + let w, s, l = picka (w-1) s tl in + w, EqualitySet.add hd s, hd::l + | hd::tl -> + let w, s, l = picka w s tl in + w, s, hd::l + else + 0, s, l + in + let in_age, ns, nl = picka in_age ns nl in + let _, ps, pl = picka in_age ps pl in + if not (EqualitySet.is_empty ps) then +(* maximal_weight := Some (weight_of_equality (EqualitySet.max_elt ps)); *) + maximal_retained_equality := Some (EqualitySet.max_elt ps); + let tbl = + EqualitySet.fold + (fun e tbl -> Indexing.index tbl e) ps (Indexing.empty_table ()) +(* if !use_fullred then *) +(* EqualitySet.fold *) +(* (fun e tbl -> Indexing.index tbl e) ps (Indexing.empty_table ()) *) +(* else *) +(* tbl *) + in + (nl, ns), (pl, ps), tbl +;; + + +let infer env sign current (active_list, active_table) = + let new_neg, new_pos = + match sign with + | Negative -> + Indexing.superposition_left env active_table current, [] + | Positive -> + let maxm, res = + Indexing.superposition_right !maxmeta env active_table current in maxmeta := maxm; - let neg, pos = infer_positive current tl in - -(* Printf.printf "risultato di superposition_right: %s %s\n%s\n\n" *) -(* (string_of_equality ~env current) (string_of_equality ~env equality) *) -(* (String.concat "\n" (List.map (string_of_equality ~env) res)); *) -(* Printf.printf "risultato di superposition_right: %s %s\n%s\n\n" *) -(* (string_of_equality ~env equality) (string_of_equality ~env current) *) -(* (String.concat "\n" (List.map (string_of_equality ~env) res')); *) - - neg, res @ res' @ pos + let rec infer_positive table = function + | [] -> [], [] + | (Negative, equality)::tl -> + let res = Indexing.superposition_left env table equality in + let neg, pos = infer_positive table tl in + res @ neg, pos + | (Positive, equality)::tl -> + let maxm, res = + Indexing.superposition_right !maxmeta env table equality in + maxmeta := maxm; + let neg, pos = infer_positive table tl in + neg, res @ pos + in + let curr_table = Indexing.index (Indexing.empty_table ()) current in + let neg, pos = infer_positive curr_table active_list in + neg, res @ pos in - match sign with - | Negative -> infer_negative current active - | Positive -> infer_positive current active + derived_clauses := !derived_clauses + (List.length new_neg) + + (List.length new_pos); + match (* !maximal_weight *)!maximal_retained_equality with + | None -> new_neg, new_pos + | Some (* w *) eq -> + let new_pos = + List.filter (fun e -> (* (weight_of_equality e) <= w *) OrderedEquality.compare e eq <= 0) new_pos in + new_neg, new_pos ;; let contains_empty env (negative, positive) = let metasenv, context, ugraph = env in try - let (proof, _, _, _) = + let found = List.find - (fun (proof, (ty, left, right), m, a) -> + (fun (w, proof, (ty, left, right, ordering), m, a) -> fst (CicReduction.are_convertible context left right ugraph)) negative in - true, Some proof + true, Some found with Not_found -> false, None ;; -let forward_simplify env (sign, current) ?passive active = - let pn, pp = +let forward_simplify env (sign, current) ?passive (active_list, active_table) = + let pl, passive_table = match passive with - | None -> [], [] - | Some ((pn, _), (pp, _)) -> - (List.map (fun e -> Negative, e) pn), - (List.map (fun e -> Positive, e) pp) - in - let all = active @ pn @ pp in - let rec find_duplicate sign current = function - | [] -> false - | (s, eq)::tl when s = sign -> - if meta_convertibility_eq current eq then true - else find_duplicate sign current tl - | _::tl -> find_duplicate sign current tl + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt in -(* let duplicate = find_duplicate sign current all in *) -(* if duplicate then *) + let all = if pl = [] then active_list else active_list @ pl in + +(* let rec find_duplicate sign current = function *) +(* | [] -> false *) +(* | (s, eq)::tl when s = sign -> *) +(* if meta_convertibility_eq current eq then true *) +(* else find_duplicate sign current tl *) +(* | _::tl -> find_duplicate sign current tl *) +(* in *) + +(* let res = *) +(* if sign = Positive then *) +(* Indexing.subsumption env active_table current *) +(* else *) +(* false *) +(* in *) +(* if res then *) (* None *) (* else *) - let rec aux env (sign, current) = function - | [] -> Some (sign, current) - | (Negative, _)::tl -> aux env (sign, current) tl - | (Positive, equality)::tl -> - let newmeta, newcurrent = - demodulation !maxmeta env current equality in - maxmeta := newmeta; - if is_identity env newcurrent then - if sign = Negative then - Some (sign, current) - else - None - else if newcurrent <> current then - aux env (sign, newcurrent) active - else - aux env (sign, newcurrent) tl + + let demodulate table current = + let newmeta, newcurrent = + Indexing.demodulation !maxmeta env table current in + maxmeta := newmeta; + if is_identity env newcurrent then + if sign = Negative then Some (sign, newcurrent) + else None + else + Some (sign, newcurrent) + in + let res = + let res = demodulate active_table current in + match res with + | None -> None + | Some (sign, newcurrent) -> + match passive_table with + | None -> res + | Some passive_table -> demodulate passive_table newcurrent in - let res = aux env (sign, current) all in match res with | None -> None - | Some (s, c) -> - if find_duplicate s c all then + | Some (Negative, c) -> + let ok = not ( + List.exists + (fun (s, eq) -> s = Negative && meta_convertibility_eq eq c) + all) + in + if ok then res else None + | Some (Positive, c) -> + if Indexing.in_index active_table c then None else - let pred (sign, eq) = - if sign <> s then false - else subsumption env c eq - in - if List.exists pred all then None - else res + match passive_table with + | None -> res + | Some passive_table -> + if Indexing.in_index passive_table c then None + else res + +(* | Some (s, c) -> if find_duplicate s c all then None else res *) + +(* if s = Utils.Negative then *) +(* res *) +(* else *) +(* if Indexing.subsumption env active_table c then *) +(* None *) +(* else ( *) +(* match passive_table with *) +(* | None -> res *) +(* | Some passive_table -> *) +(* if Indexing.subsumption env passive_table c then *) +(* None *) +(* else *) +(* res *) +(* ) *) + +(* let pred (sign, eq) = *) +(* if sign <> s then false *) +(* else subsumption env c eq *) +(* in *) +(* if List.exists pred all then None *) +(* else res *) ;; +type fs_time_info_t = { + mutable build_all: float; + mutable demodulate: float; + mutable subsumption: float; +};; + +let fs_time_info = { build_all = 0.; demodulate = 0.; subsumption = 0. };; + let forward_simplify_new env (new_neg, new_pos) ?passive active = - let pn, pp = + let t1 = Unix.gettimeofday () in + + let active_list, active_table = active in + let pl, passive_table = match passive with - | None -> [], [] - | Some ((pn, _), (pp, _)) -> - (List.map (fun e -> Negative, e) pn), - (List.map (fun e -> Positive, e) pp) + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt in - let all = active @ pn @ pp in - let remove_identities equalities = - let ok eq = not (is_identity env eq) in - List.filter ok equalities + let all = active_list @ pl in + + let t2 = Unix.gettimeofday () in + fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1); + + let demodulate table target = + let newmeta, newtarget = Indexing.demodulation !maxmeta env table target in + maxmeta := newmeta; + newtarget in - let rec simpl all' target = - match all' with - | [] -> target - | (Negative, _)::tl -> simpl tl target - | (Positive, source)::tl -> - let newmeta, newtarget = demodulation !maxmeta env target source in - maxmeta := newmeta; - if is_identity env newtarget then newtarget - else if newtarget <> target then ( -(* Printf.printf "OK:\n%s\n%s\n" *) -(* (string_of_equality ~env target) *) -(* (string_of_equality ~env newtarget); *) -(* print_newline (); *) - simpl all newtarget - ) - else simpl tl newtarget +(* let f sign' target (sign, eq) = *) +(* if sign <> sign' then false *) +(* else subsumption env target eq *) +(* in *) + + let t1 = Unix.gettimeofday () in + + let new_neg, new_pos = + let new_neg = List.map (demodulate active_table) new_neg + and new_pos = List.map (demodulate active_table) new_pos in + match passive_table with + | None -> new_neg, new_pos + | Some passive_table -> + List.map (demodulate passive_table) new_neg, + List.map (demodulate passive_table) new_pos in - let new_neg = List.map (simpl all) new_neg - and new_pos = remove_identities (List.map (simpl all) new_pos) in + + let t2 = Unix.gettimeofday () in + fs_time_info.demodulate <- fs_time_info.demodulate +. (t2 -. t1); + let new_pos_set = - List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty new_pos + List.fold_left + (fun s e -> + if not (Inference.is_identity env e) then + if EqualitySet.mem e s then s + else EqualitySet.add e s + else s) + EqualitySet.empty new_pos in let new_pos = EqualitySet.elements new_pos_set in - let f sign' target (sign, eq) = -(* Printf.printf "f %s <%s> (%s, <%s>)\n" *) -(* (string_of_sign sign') (string_of_equality ~env target) *) -(* (string_of_sign sign) (string_of_equality ~env eq); *) - if sign <> sign' then false - else subsumption env target eq + + let subs = + match passive_table with + | None -> + (fun e -> not (Indexing.subsumption env active_table e)) + | Some passive_table -> + (fun e -> not ((Indexing.subsumption env active_table e) || + (Indexing.subsumption env passive_table e))) in + + let t1 = Unix.gettimeofday () in + +(* let new_neg, new_pos = *) +(* List.filter subs new_neg, *) +(* List.filter subs new_pos *) +(* in *) + +(* let new_neg, new_pos = *) +(* (List.filter (fun e -> not (List.exists (f Negative e) all)) new_neg, *) +(* List.filter (fun e -> not (List.exists (f Positive e) all)) new_pos) *) +(* in *) + + let t2 = Unix.gettimeofday () in + fs_time_info.subsumption <- fs_time_info.subsumption +. (t2 -. t1); + + let is_duplicate = + match passive_table with + | None -> + (fun e -> not (Indexing.in_index active_table e)) + | Some passive_table -> + (fun e -> + not ((Indexing.in_index active_table e) || + (Indexing.in_index passive_table e))) + in + new_neg, List.filter is_duplicate new_pos + (* new_neg, new_pos *) - (List.filter (fun e -> not (List.exists (f Negative e) all)) new_neg, - List.filter (fun e -> not (List.exists (f Positive e) all)) new_pos) + +(* let res = *) +(* (List.filter (fun e -> not (List.exists (f Negative e) all)) new_neg, *) +(* List.filter (fun e -> not (List.exists (f Positive e) all)) new_pos) *) +(* in *) +(* res *) ;; -let backward_simplify_active env (new_neg, new_pos) active = - let new_pos = List.map (fun e -> Positive, e) new_pos in - let active, newa = +let backward_simplify_active env new_pos new_table active = + let active_list, active_table = active in + let active_list, newa = List.fold_right (fun (s, equality) (res, newn) -> - match forward_simplify env (s, equality) new_pos with - | None when s = Negative -> - Printf.printf "\nECCO QUI: %s\n" - (string_of_equality ~env equality); - print_newline (); - res, newn + match forward_simplify env (s, equality) (new_pos, new_table) with | None -> res, newn | Some (s, e) -> if equality = e then (s, e)::res, newn - else + else res, (s, e)::newn) - active ([], []) + active_list ([], []) in let find eq1 where = List.exists (fun (s, e) -> meta_convertibility_eq eq1 e) where in let active, newa = - let f (s, eq) res = - if (is_identity env eq) || (find eq res) then res else (s, eq)::res - in List.fold_right - (fun (s, eq) res -> - if (is_identity env eq) || (find eq res) then res else (s, eq)::res) - active [], + (fun (s, eq) (res, tbl) -> + if List.mem (s, eq) res then + res, tbl + else if (is_identity env eq) || (find eq res) then ( + res, tbl + ) (* else if (find eq res) then *) +(* res, tbl *) + else + (s, eq)::res, if s = Negative then tbl else Indexing.index tbl eq) + active_list ([], Indexing.empty_table ()), List.fold_right (fun (s, eq) (n, p) -> - if (s <> Negative) && (is_identity env eq) then + if (s <> Negative) && (is_identity env eq) then ( (n, p) - else + ) else if s = Negative then eq::n, p else n, eq::p) newa ([], []) @@ -391,11 +667,10 @@ let backward_simplify_active env (new_neg, new_pos) active = ;; -let backward_simplify_passive env (new_neg, new_pos) passive = - let new_pos = List.map (fun e -> Positive, e) new_pos in - let (nl, ns), (pl, ps) = passive in +let backward_simplify_passive env new_pos new_table passive = + let (nl, ns), (pl, ps), passive_table = passive in let f sign equality (resl, ress, newn) = - match forward_simplify env (sign, equality) new_pos with + match forward_simplify env (sign, equality) (new_pos, new_table) with | None -> resl, EqualitySet.remove equality ress, newn | Some (s, e) -> if equality = e then @@ -406,133 +681,211 @@ let backward_simplify_passive env (new_neg, new_pos) passive = in let nl, ns, newn = List.fold_right (f Negative) nl ([], ns, []) and pl, ps, newp = List.fold_right (f Positive) pl ([], ps, []) in + let passive_table = + List.fold_left + (fun tbl e -> Indexing.index tbl e) (Indexing.empty_table ()) pl + in match newn, newp with - | [], [] -> ((nl, ns), (pl, ps)), None - | _, _ -> ((nl, ns), (pl, ps)), Some (newn, newp) + | [], [] -> ((nl, ns), (pl, ps), passive_table), None + | _, _ -> ((nl, ns), (pl, ps), passive_table), Some (newn, newp) ;; let backward_simplify env new' ?passive active = - let active, newa = backward_simplify_active env new' active in + let new_pos, new_table = + List.fold_left + (fun (l, t) e -> (Positive, e)::l, Indexing.index t e) + ([], Indexing.empty_table ()) (snd new') + in + let active, newa = backward_simplify_active env new_pos new_table active in match passive with | None -> - active, (([], EqualitySet.empty), ([], EqualitySet.empty)), newa, None + active, (make_passive [] []), newa, None | Some passive -> let passive, newp = - backward_simplify_passive env new' passive in + backward_simplify_passive env new_pos new_table passive in active, passive, newa, newp ;; +let get_selection_estimate () = + elapsed_time := (Unix.gettimeofday ()) -. !start_time; +(* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *) + int_of_float ( + ceil ((float_of_int !processed_clauses) *. + ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.))) +;; + let rec given_clause env passive active = + let time1 = Unix.gettimeofday () in + + let selection_estimate = get_selection_estimate () in + let kept = size_of_passive passive in + let passive = + if !time_limit = 0. || !processed_clauses = 0 then + passive + else if !elapsed_time > !time_limit then ( + Printf.printf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time; + make_passive [] [] + ) else if kept > selection_estimate then ( + Printf.printf ("Too many passive equalities: pruning... (kept: %d, " ^^ + "selection_estimate: %d)\n") kept selection_estimate; + prune_passive selection_estimate active passive + ) else + passive + in + + let time2 = Unix.gettimeofday () in + passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); + + kept_clauses := (size_of_passive passive) + (size_of_active active); + match passive_is_empty passive with | true -> Failure | false -> -(* Printf.printf "before select\n"; *) let (sign, current), passive = select env passive active in -(* Printf.printf "before simplification: sign: %s\ncurrent: %s\n\n" *) -(* (string_of_sign sign) (string_of_equality ~env current); *) - match forward_simplify env (sign, current) ~passive active with -(* | None when sign = Negative -> *) -(* Printf.printf "OK!!! %s %s" (string_of_sign sign) *) -(* (string_of_equality ~env current); *) -(* print_newline (); *) -(* let proof, _, _, _ = current in *) -(* Success (Some proof, env) *) + let time1 = Unix.gettimeofday () in + let res = forward_simplify env (sign, current) ~passive active in + let time2 = Unix.gettimeofday () in + forward_simpl_time := !forward_simpl_time +. (time2 -. time1); + match res with | None -> -(* Printf.printf "avanti... %s %s" (string_of_sign sign) *) -(* (string_of_equality ~env current); *) -(* print_newline (); *) given_clause env passive active | Some (sign, current) -> if (sign = Negative) && (is_identity env current) then ( Printf.printf "OK!!! %s %s" (string_of_sign sign) (string_of_equality ~env current); print_newline (); - let proof, _, _, _ = current in - Success (Some proof, env) + Success (Some current, env) ) else ( print_endline "\n================================================"; Printf.printf "selected: %s %s" (string_of_sign sign) (string_of_equality ~env current); print_newline (); + let t1 = Unix.gettimeofday () in let new' = infer env sign current active in - let res, proof = contains_empty env new' in + let t2 = Unix.gettimeofday () in + infer_time := !infer_time +. (t2 -. t1); + + let res, goal = contains_empty env new' in if res then - Success (proof, env) - else - let new' = forward_simplify_new env new' active in + Success (goal, env) + else + let t1 = Unix.gettimeofday () in + let new' = forward_simplify_new env new' (* ~passive *) active in + let t2 = Unix.gettimeofday () in + let _ = + forward_simpl_new_time := !forward_simpl_new_time +. (t2 -. t1) + in let active = match sign with | Negative -> active | Positive -> + let t1 = Unix.gettimeofday () in let active, _, newa, _ = backward_simplify env ([], [current]) active in + let t2 = Unix.gettimeofday () in + backward_simpl_time := !backward_simpl_time +. (t2 -. t1); match newa with | None -> active | Some (n, p) -> - let nn = List.map (fun e -> Negative, e) n - and pp = List.map (fun e -> Positive, e) p in - nn @ active @ pp - in - let _ = - Printf.printf "active:\n%s\n" - (String.concat "\n" - ((List.map - (fun (s, e) -> (string_of_sign s) ^ " " ^ - (string_of_equality ~env e)) active))); - print_newline (); - in - let _ = - match new' with - | neg, pos -> - Printf.printf "new':\n%s\n" - (String.concat "\n" - ((List.map - (fun e -> "Negative " ^ - (string_of_equality ~env e)) neg) @ - (List.map - (fun e -> "Positive " ^ - (string_of_equality ~env e)) pos))); - print_newline (); + let al, tbl = active in + let nn = List.map (fun e -> Negative, e) n in + let pp, tbl = + List.fold_right + (fun e (l, t) -> + (Positive, e)::l, + Indexing.index tbl e) + p ([], tbl) + in + nn @ al @ pp, tbl in +(* let _ = *) +(* Printf.printf "active:\n%s\n" *) +(* (String.concat "\n" *) +(* ((List.map *) +(* (fun (s, e) -> (string_of_sign s) ^ " " ^ *) +(* (string_of_equality ~env e)) (fst active)))); *) +(* print_newline (); *) +(* in *) +(* let _ = *) +(* match new' with *) +(* | neg, pos -> *) +(* Printf.printf "new':\n%s\n" *) +(* (String.concat "\n" *) +(* ((List.map *) +(* (fun e -> "Negative " ^ *) +(* (string_of_equality ~env e)) neg) @ *) +(* (List.map *) +(* (fun e -> "Positive " ^ *) +(* (string_of_equality ~env e)) pos))); *) +(* print_newline (); *) +(* in *) match contains_empty env new' with | false, _ -> let active = + let al, tbl = active in match sign with - | Negative -> (sign, current)::active - | Positive -> active @ [(sign, current)] + | Negative -> (sign, current)::al, tbl + | Positive -> + al @ [(sign, current)], Indexing.index tbl current in let passive = add_to_passive passive new' in - let (_, ns), (_, ps) = passive in - Printf.printf "passive:\n%s\n" - (String.concat "\n" - ((List.map (fun e -> "Negative " ^ - (string_of_equality ~env e)) - (EqualitySet.elements ns)) @ - (List.map (fun e -> "Positive " ^ - (string_of_equality ~env e)) - (EqualitySet.elements ps)))); - print_newline (); +(* let (_, ns), (_, ps), _ = passive in *) +(* Printf.printf "passive:\n%s\n" *) +(* (String.concat "\n" *) +(* ((List.map (fun e -> "Negative " ^ *) +(* (string_of_equality ~env e)) *) +(* (EqualitySet.elements ns)) @ *) +(* (List.map (fun e -> "Positive " ^ *) +(* (string_of_equality ~env e)) *) +(* (EqualitySet.elements ps)))); *) +(* print_newline (); *) given_clause env passive active - | true, proof -> - Success (proof, env) + | true, goal -> + Success (goal, env) ) ;; let rec given_clause_fullred env passive active = + let time1 = Unix.gettimeofday () in + + let selection_estimate = get_selection_estimate () in + let kept = size_of_passive passive in + let passive = + if !time_limit = 0. || !processed_clauses = 0 then + passive + else if !elapsed_time > !time_limit then ( + Printf.printf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time; + make_passive [] [] + ) else if kept > selection_estimate then ( + Printf.printf ("Too many passive equalities: pruning... (kept: %d, " ^^ + "selection_estimate: %d)\n") kept selection_estimate; + prune_passive selection_estimate active passive + ) else + passive + in + + let time2 = Unix.gettimeofday () in + passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); + + kept_clauses := (size_of_passive passive) + (size_of_active active); + match passive_is_empty passive with | true -> Failure | false -> -(* Printf.printf "before select\n"; *) let (sign, current), passive = select env passive active in -(* Printf.printf "before simplification: sign: %s\ncurrent: %s\n\n" *) -(* (string_of_sign sign) (string_of_equality ~env current); *) - match forward_simplify env (sign, current) ~passive active with + let time1 = Unix.gettimeofday () in + let res = forward_simplify env (sign, current) ~passive active in + let time2 = Unix.gettimeofday () in + forward_simpl_time := !forward_simpl_time +. (time2 -. time1); + match res with | None -> given_clause_fullred env passive active | Some (sign, current) -> @@ -540,41 +893,36 @@ let rec given_clause_fullred env passive active = Printf.printf "OK!!! %s %s" (string_of_sign sign) (string_of_equality ~env current); print_newline (); - let proof, _, _, _ = current in - Success (Some proof, env) + Success (Some current, env) ) else ( print_endline "\n================================================"; Printf.printf "selected: %s %s" (string_of_sign sign) (string_of_equality ~env current); print_newline (); + let t1 = Unix.gettimeofday () in let new' = infer env sign current active in + let t2 = Unix.gettimeofday () in + infer_time := !infer_time +. (t2 -. t1); let active = if is_identity env current then active else + let al, tbl = active in match sign with - | Negative -> (sign, current)::active - | Positive -> active @ [(sign, current)] + | Negative -> (sign, current)::al, tbl + | Positive -> al @ [(sign, current)], Indexing.index tbl current in -(* let _ = *) -(* match new' with *) -(* | neg, pos -> *) -(* Printf.printf "new' before simpl:\n%s\n" *) -(* (String.concat "\n" *) -(* ((List.map *) -(* (fun e -> "Negative " ^ *) -(* (string_of_equality ~env e)) neg) @ *) -(* (List.map *) -(* (fun e -> "Positive " ^ *) -(* (string_of_equality ~env e)) pos))); *) -(* print_newline (); *) -(* in *) let rec simplify new' active passive = + let t1 = Unix.gettimeofday () in let new' = forward_simplify_new env new' ~passive active in + let t2 = Unix.gettimeofday () in + forward_simpl_new_time := !forward_simpl_new_time +. (t2 -. t1); + let t1 = Unix.gettimeofday () in let active, passive, newa, retained = - backward_simplify env new' ~passive active - in + backward_simplify env new' ~passive active in + let t2 = Unix.gettimeofday () in + backward_simpl_time := !backward_simpl_time +. (t2 -. t1); match newa, retained with | None, None -> active, passive, new' | Some (n, p), None @@ -586,43 +934,38 @@ let rec given_clause_fullred env passive active = simplify (nn @ n @ rn, np @ p @ rp) active passive in let active, passive, new' = simplify new' active passive in - let _ = - Printf.printf "active:\n%s\n" - (String.concat "\n" - ((List.map - (fun (s, e) -> (string_of_sign s) ^ " " ^ - (string_of_equality ~env e)) active))); - print_newline (); - in - let _ = - match new' with - | neg, pos -> - Printf.printf "new':\n%s\n" - (String.concat "\n" - ((List.map - (fun e -> "Negative " ^ - (string_of_equality ~env e)) neg) @ - (List.map - (fun e -> "Positive " ^ - (string_of_equality ~env e)) pos))); - print_newline (); - in + + let k = size_of_passive passive in + if k < (kept - 1) then + processed_clauses := !processed_clauses + (kept - 1 - k); + +(* let _ = *) +(* Printf.printf "active:\n%s\n" *) +(* (String.concat "\n" *) +(* ((List.map *) +(* (fun (s, e) -> (string_of_sign s) ^ " " ^ *) +(* (string_of_equality ~env e)) (fst active)))); *) +(* print_newline (); *) +(* in *) +(* let _ = *) +(* match new' with *) +(* | neg, pos -> *) +(* Printf.printf "new':\n%s\n" *) +(* (String.concat "\n" *) +(* ((List.map *) +(* (fun e -> "Negative " ^ *) +(* (string_of_equality ~env e)) neg) @ *) +(* (List.map *) +(* (fun e -> "Positive " ^ *) +(* (string_of_equality ~env e)) pos))); *) +(* print_newline (); *) +(* in *) match contains_empty env new' with | false, _ -> let passive = add_to_passive passive new' in -(* let (_, ns), (_, ps) = passive in *) -(* Printf.printf "passive:\n%s\n" *) -(* (String.concat "\n" *) -(* ((List.map (fun e -> "Negative " ^ *) -(* (string_of_equality ~env e)) *) -(* (EqualitySet.elements ns)) @ *) -(* (List.map (fun e -> "Positive " ^ *) -(* (string_of_equality ~env e)) *) -(* (EqualitySet.elements ps)))); *) -(* print_newline (); *) given_clause_fullred env passive active - | true, proof -> - Success (proof, env) + | true, goal -> + Success (goal, env) ) ;; @@ -663,39 +1006,59 @@ let main () = let env = (metasenv, context, ugraph) in try let term_equality = equality_of_term meta_proof goal in - let meta_proof, (eq_ty, left, right), _, _ = term_equality in - let active = [] in + let _, meta_proof, (eq_ty, left, right, ordering), _, _ = term_equality in + let active = make_active () in let passive = make_passive [term_equality] equalities in - Printf.printf "\ncurrent goal: %s ={%s} %s\n" - (PP.ppterm left) (PP.ppterm eq_ty) (PP.ppterm right); + Printf.printf "\ncurrent goal: %s\n" + (string_of_equality ~env term_equality); Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context); Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv); - Printf.printf "\nequalities:\n"; - List.iter - (function (_, (ty, t1, t2), _, _) -> - let w1 = weight_of_term t1 in - let w2 = weight_of_term t2 in - let res = !compare_terms t1 t2 in - Printf.printf "{%s}: %s<%s> %s %s<%s>\n" (PP.ppterm ty) - (PP.ppterm t1) (string_of_weight w1) - (string_of_comparison res) - (PP.ppterm t2) (string_of_weight w2)) - equalities; + Printf.printf "\nequalities:\n%s\n" + (String.concat "\n" + (List.map + (string_of_equality ~env) + equalities)); print_endline "--------------------------------------------------"; let start = Unix.gettimeofday () in print_endline "GO!"; - let res = !given_clause_ref env passive active in + start_time := Unix.gettimeofday (); + let res = + (if !use_fullred then given_clause_fullred else given_clause) + env passive active + in let finish = Unix.gettimeofday () in - match res with - | Failure -> - Printf.printf "NO proof found! :-(\n\n" - | Success (Some proof, env) -> - Printf.printf "OK, found a proof!:\n%s\n%.9f\n" (PP.ppterm proof) - (finish -. start); - | Success (None, env) -> - Printf.printf "Success, but no proof?!?\n\n" + let _ = + match res with + | Failure -> + Printf.printf "NO proof found! :-(\n\n" + | Success (Some goal, env) -> + Printf.printf "OK, found a proof!\n"; + let proof = Inference.build_term_proof goal in + print_endline (PP.pp proof (names_of_context context)); + print_endline (string_of_float (finish -. start)); + | Success (None, env) -> + Printf.printf "Success, but no proof?!?\n\n" + in + Printf.printf ("infer_time: %.9f\nforward_simpl_time: %.9f\n" ^^ + "forward_simpl_new_time: %.9f\n" ^^ + "backward_simpl_time: %.9f\n") + !infer_time !forward_simpl_time !forward_simpl_new_time + !backward_simpl_time; + Printf.printf "passive_maintainance_time: %.9f\n" + !passive_maintainance_time; + Printf.printf " successful unification/matching time: %.9f\n" + !Indexing.match_unif_time_ok; + Printf.printf " failed unification/matching time: %.9f\n" + !Indexing.match_unif_time_no; + Printf.printf " indexing retrieval time: %.9f\n" + !Indexing.indexing_retrieval_time; + Printf.printf " demodulate_term.build_newtarget_time: %.9f\n" + !Indexing.build_newtarget_time; + Printf.printf "derived %d clauses, kept %d clauses.\n" + !derived_clauses !kept_clauses; with exc -> print_endline ("EXCEPTION: " ^ (Printexc.to_string exc)); + raise exc ;; @@ -707,7 +1070,8 @@ let _ = and set_conf f = configuration_file := f and set_lpo () = Utils.compare_terms := lpo and set_kbo () = Utils.compare_terms := nonrec_kbo - and set_fullred () = given_clause_ref := given_clause_fullred + and set_fullred () = use_fullred := true + and set_time_limit v = time_limit := float_of_int v in Arg.parse [ "-f", Arg.Unit set_fullred, "Use full-reduction strategy"; @@ -722,6 +1086,8 @@ let _ = "-lpo", Arg.Unit set_lpo, "Use lpo term ordering"; "-kbo", Arg.Unit set_kbo, "Use (non-recursive) kbo term ordering (default)"; + + "-l", Arg.Int set_time_limit, "Time limit (in seconds)"; ] (fun a -> ()) "Usage:" in Helm_registry.load_from !configuration_file;