Commit 41e0c512 authored by lgondelman's avatar lgondelman

induction_int_lex : new induction tactic (labels only, no heuristic provided)...

induction_int_lex : new induction tactic (labels only, no heuristic provided) for ordered int tuples.
parent 45b0adf7
......@@ -111,6 +111,10 @@ let debug_verbose = Debug.register_info_flag "induction-verbose"
~desc:"Same@ as@ induction, but@ print@ also@ the@ variables, the@ \
heuristics@ and@ the lexicographic@ order@ used."
let debug_int = Debug.register_info_flag "induction_int_lex"
~desc:"About@ the@ transformation@ of@ the@ goal@ using@ induction@ on@ \
the@ tuples@ of@ integers."
let print_ty_skm skm =
List.iter
(fun (p,svs) ->
......@@ -343,6 +347,9 @@ let make_induction_lex lexl rql t =
let t = t_forall_close (v.lq @ [v.vs]) [] t in t
in aux lexl (t_forall_close rql [] t)
let induction_ty_lex km t0 =
let qvs, qvl, t = decompose_forall t0 in
let lblvl = qvl_labeled qvl in
......@@ -380,80 +387,109 @@ let () =
Trans.register_transform_l "induction_ty_lex" (Trans.store induction_ty_lex)
~desc_labels ~desc:"TODO: induction on type with lexicographic order"
(***************************************************************************)
(********************** INDUCTION TACTIC FOR INTEGERS **********************)
(*************************** WITH LEX. ORDER ***************************)
(***************************************************************************)
let filter_int v = ty_equal v.vs_ty ty_int
(* induction_int_lex : induction tactic for ordered int tuples.
No heuristic is provided. Use labels. Generalized variables inside
the induction hypothesis are the variables on the right of the rightmost
induction variable.*)
(*HEURISTICS SEARCH FOR CANDIDATES IN THE BODY OF THE FORMULA*)
let t_candidates filter km qvs t =
let int_candidate = (fun acc t ->
match t.t_node with
| Tvar x when Svs.mem x qvs && ty_equal x.vs_ty ty_int ->
Svs.add x acc
| _ -> acc)
in
let arg_candidate = (fun acc t ->
match t.t_node with
| Tvar x when Svs.mem x qvs ->
begin match x.vs_ty.ty_node with
| Tyvar _ -> acc
| Tyapp _ -> Svs.add x acc
end
| _ -> acc)
in
let defn_candidate = (fun vs_acc ls tl ->
match (find_logic_definition km ls) with
| Some defn ->
let vs_acc = List.fold_left int_candidate vs_acc tl in
begin match ls_defn_decrease defn with
| [i] -> arg_candidate vs_acc (List.nth tl i)
| h :: _ ->
arg_candidate vs_acc (List.nth tl h)
| _ -> vs_acc
end
| None -> vs_acc)
in
let rec t_candidate vs_acc t =
let vs_acc = match t.t_node with
| Tapp (ls, tl) -> defn_candidate vs_acc ls tl
| _ -> vs_acc
in t_fold t_candidate vs_acc t
in Svs.filter filter (t_candidate Svs.empty t)
(*CANDIDATE SELECTION*)
let heuristic_svs vset = Svs.choose vset
let int_strong_induction (le_int,lt_int) x t =
let k = Term.create_vsymbol (Ident.id_clone x.vs_name) ty_int in
(* 0 <= k < x *)
let ineq = t_and (ps_app le_int [t_int_const "0"; t_var k])
(ps_app lt_int [t_var k; t_var x]) in
(* forall k. 0 <= k < x -> P[x <- k] *)
let ih =
t_forall_close [k] [] (t_implies ineq (t_subst_single x (t_var k) t)) in
t_forall_close [x] [] (t_implies ih t)
let induction_int km (le_int,lt_int) t0 =
let qvs, qvl, t = decompose_forall t0 in
let vset = t_candidates filter_int km qvs t in
if Svs.is_empty vset
(* separate prenex universal quantification from the body of the formula*)
let decompose_int_forall t =
let rec aux qvl_acc t = match t.t_node with
| Tquant (Tforall, qt) ->
let qvl, _, t = t_open_quant qt in aux (qvl_acc @ qvl) t
| _ -> qvl_acc, t
in aux [] t
(* find labeled variables (for induction variables),
and the rest of the quantified variables after the last labeled variable
(for the variables to generalize inside induction hypothesis).
Ex: the result of Va.x1.b.x2.c.x3.d.P is [a.x1.b.x2.c.x3][x1.x2.x3][d]*)
let split_int_qlv_labeled qvl =
let rec aux left_acc ind_acc gen_acc = function
| [] -> List.rev left_acc, List.rev ind_acc, gen_acc
| v :: tl ->
let lbls =
Slab.filter (fun v -> v.lab_string = "induction") v.vs_name.id_label
in if not (Slab.is_empty lbls)
then aux (v :: (gen_acc @ left_acc)) (v :: ind_acc) [] tl
else aux left_acc ind_acc (v :: gen_acc) tl
in aux [] [] [] qvl
(*
input: ordered induction variables, rightmost neutral variables
output:
new variables for rightmost neutral variables (generalization),
new variabkes for induction hypothesis and
the complete condition for induction variable non-negativeness and
lexicographic order.
For instance, if input: ivl = (x1,x2); rvl = (d,e)
then output:
(d',e') ~ 'generalization variables',
(x1',x2',x3') ~ 'induction variables'
(0 <= x1'/\0 <= x2'/\(x1' < x1 \/ x1' = x1 /\ x2' < x2) ~ 'hyp. condition' *)
let lex_order_ivl (le_int,lt_int) ivl rvl =
let gen_rvl, (hd,hd',tl,tl') =
let create_v v = Term.create_vsymbol (Ident.id_clone v.vs_name) ty_int in
match (ivl, List.map create_v ivl) with
| v :: tl, v':: tl' -> ((List.map create_v rvl), (v, v', tl, tl'))
| _ -> assert false in
let nonneg_ivl' =
let positive v = ps_app le_int [t_int_const "0"; t_var v] in
List.fold_left (fun t v -> t_and t (positive v)) (positive hd') tl' in
let lt_lex =
let lt_hd = ps_app lt_int [t_var hd'; t_var hd] in
let eq_on_left (x, x', left, left') =
let teq = t_equ (t_var x) (t_var x') in
List.fold_left2
(fun t x x' -> t_and t (t_equ (t_var x) (t_var x'))) teq left left' in
let rec lex_ord (hd, hd', left, left') acc_or = function
| [],[] -> acc_or
| v :: tl, v' :: tl' ->
let v_eql = eq_on_left (hd, hd', left, left') in
let v_lt = ps_app lt_int [t_var v'; t_var v] in
lex_ord
(v, v', hd :: left, hd' :: left')
(t_or acc_or (t_and v_eql v_lt)) (tl,tl')
| _ -> assert false
in lex_ord (hd, hd', [],[]) lt_hd (tl, tl') in
gen_rvl, (hd' :: tl'), t_and nonneg_ivl' lt_lex
(*returns the resulting formula with induction hypothesis.
The formula however is still not closed (by the quantifiers before
the rightmost neutral quantifiers). *)
let int_strong_induction_lex (le_int,lt_int) ivl rvl t =
let (gen_rvl, ind_ivl, hyp_cond) =
lex_order_ivl (le_int,lt_int) ivl rvl in
let hyp_goal =
List.fold_left2
(fun t x x' ->
t_subst_single x (t_var x') t) t (ivl @ rvl) (ind_ivl @ gen_rvl) in
let ind_hyp =
t_forall_close (ind_ivl @ gen_rvl) [] (t_implies hyp_cond hyp_goal) in
let open_t = t_implies ind_hyp (t_forall_close rvl [] t) in open_t
let induction_int_lex _km (le_int,lt_int) t0 =
let qvl, t = decompose_int_forall t0 in
let lvl,ivl, genl = split_int_qlv_labeled qvl in
if (ivl = [])
then [t0]
else begin
let x = heuristic_svs vset in
let qvl1, qvl2 = split_quantifiers x qvl in
let t = t_forall_close qvl2 [] t in
let t = int_strong_induction (le_int,lt_int) x t in
let t = t_forall_close qvl1 [] t in
if Debug.test_flag debug then
else
begin
let t = int_strong_induction_lex (le_int,lt_int) ivl genl t in
let t = t_forall_close lvl [] t in
if Debug.test_flag debug_int then
(Format.printf "Old Task: %a \n@." Pretty.print_term t0;
Format.printf "New Task: %a \n@." Pretty.print_term t);
[t]
end
let induction_int th_int = function
let induction_int_lex th_int = function
| Some
{ task_decl = { td_node = Decl { d_node = Dprop (Pgoal, pr, f) } };
task_prev = prev; task_known = km } as t ->
......@@ -463,18 +499,19 @@ let induction_int th_int = function
let lt_int = ns_find_ls th_int.th_export ["infix <"] in
if not (Mid.mem le_int.ls_name km) then raise Exit;
List.map (add_prop_decl prev Pgoal pr)
(induction_int km (le_int, lt_int) f)
(induction_int_lex km (le_int, lt_int) f)
with Exit -> [t] end
| _ -> assert false
let () =
Trans.register_env_transform_l "induction_int"
Trans.register_env_transform_l "induction_int_lex"
(fun env ->
let th_int = Env.find_theory env ["int"] "Int" in
Trans.store (induction_int th_int))
Trans.store (induction_int_lex th_int))
~desc_labels ~desc:"TODO: induction on integers"
(*
Local Variables:
compile-command: "unset LANG; make -C ../.. bin/why3.byte"
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment