Commit c511399b authored by Sylvain Dailler's avatar Sylvain Dailler

fix #22 Add arguments to induction_pr_arg

Also fix induction_pr_arg so that it adds the right attribute inside the
goal.
parent 24cb7442
...@@ -25,6 +25,8 @@ Transformations ...@@ -25,6 +25,8 @@ Transformations
* Fix crash of eliminate_unknown_types * Fix crash of eliminate_unknown_types
* Giving too many arguments to a transformation do not display a popup anymore * Giving too many arguments to a transformation do not display a popup anymore
* Fix behavior of induction_arg_ty_lex (now equivalent to induction_ty_lex) * Fix behavior of induction_arg_ty_lex (now equivalent to induction_ty_lex)
* Add optional arguments to induction_arg_pr (containing what is to be
generalized in the induction). Also, fixing its behavior.
Counterexamples Counterexamples
* Improved display of counterexamples in Task view * Improved display of counterexamples in Task view
......
...@@ -512,6 +512,11 @@ let rec wrap_to_store : type a b. (a, b) trans_typ -> a -> string list -> Env.en ...@@ -512,6 +512,11 @@ let rec wrap_to_store : type a b. (a, b) trans_typ -> a -> string list -> Env.en
let list = let list =
List.map (fun id -> id.Ptree.id_str) (parse_list_ident s') in List.map (fun id -> id.Ptree.id_str) (parse_list_ident s') in
wrap_to_store t' (f (Some list)) tail env tables task wrap_to_store t' (f (Some list)) tail env tables task
| Tlist t' ->
let pr_list = parse_list_qualid s' in
let pr_list =
List.map (fun id -> find_symbol id tables) pr_list in
wrap_to_store t' (f (Some pr_list)) tail env tables task
| _ -> raise (Arg_expected (string_of_trans_typ t', s')) | _ -> raise (Arg_expected (string_of_trans_typ t', s'))
end end
| Topt (_, t'), _ -> | Topt (_, t'), _ ->
......
...@@ -76,22 +76,30 @@ let revert ?tr g d : Term.term = ...@@ -76,22 +76,30 @@ let revert ?tr g d : Term.term =
| Ddata _ -> raise (Arg_trans "revert: cannot revert type") | Ddata _ -> raise (Arg_trans "revert: cannot revert type")
| Dparam ls -> | Dparam ls ->
(try (try
let attrs = match tr with let attrs = Opt.map (fun x -> Ident.Sattr.add x Ident.Sattr.empty) (match tr with
| None -> None | None -> None
| Some tr -> Some (tr ls) in | Some tr -> tr (Tslsymbol ls)) in
let new_ident = Ident.id_fresh ?attrs ls.ls_name.Ident.id_string in let new_ident = Ident.id_fresh ?attrs ls.ls_name.Ident.id_string in
let new_var = Term.create_vsymbol new_ident (Opt.get ls.Term.ls_value) in let new_var = Term.create_vsymbol new_ident (Opt.get ls.Term.ls_value) in
let g = t_replace (t_app_infer ls []) (t_var new_var) g in let g = t_replace (t_app_infer ls []) (t_var new_var) g in
t_forall_close [new_var] [] g t_forall_close [new_var] [] g
with with
| e -> raise (Arg_trans ("revert: cannot revert:" ^ ls.ls_name.Ident.id_string))) | _ -> raise (Arg_trans ("revert: cannot revert:" ^ ls.ls_name.Ident.id_string)))
(* TODO extend this *) (* TODO extend this *)
| Dlogic _ -> | Dlogic _ ->
raise (Arg_trans "revert: cannot revert logic decls") raise (Arg_trans "revert: cannot revert logic decls")
| Dind _ -> | Dind _ ->
raise (Arg_trans "revert: cannot revert induction decls") raise (Arg_trans "revert: cannot revert induction decls")
| Dprop (k, _pr, t) when k <> Pgoal -> | Dprop (k, pr, t) when k <> Pgoal ->
Term.t_implies t g let t = match tr with
| None -> t
| Some tr ->
begin match tr (Tsprsymbol pr) with
| None -> t
| Some attr -> t_attr_add attr t
end
in
Term.t_implies t g
| Dprop (Pgoal, _, _) -> raise (Arg_trans "revert: cannot revert goal") | Dprop (Pgoal, _, _) -> raise (Arg_trans "revert: cannot revert goal")
| _ -> raise (Arg_trans "revert: please report") | _ -> raise (Arg_trans "revert: please report")
......
...@@ -9,10 +9,10 @@ ...@@ -9,10 +9,10 @@
(* *) (* *)
(********************************************************************) (********************************************************************)
(* [tr] gives a function that gives a set of attributes to the fresh elements (* [tr] is a function that associates a symbol of the task with an attribute.
generated during the revert. It allows in particular to add [@induction] for This is used to add new attributes (such as @induction) on some quantified
induction_ty_lex. variables (see induction_arg_pr).
*) *)
val revert_tr_symbol: val revert_tr_symbol:
?tr:(Term.lsymbol -> Ident.Sattr.t) -> ?tr:(Args_wrapper.symbol -> Ident.attribute option) ->
Args_wrapper.symbol list -> Task.task Trans.trans Args_wrapper.symbol list -> Task.task Trans.trans
...@@ -349,13 +349,13 @@ let () = ...@@ -349,13 +349,13 @@ let () =
let induction_on_hyp ls = let induction_on_hyp ls =
(* We add the induction attribute on the reverted symbol *) (* We add the induction attribute on the reverted symbol *)
let tr = Some let tr s = (* Add induction attribute *only* on ls *)
(fun s -> (* Add induction attribute *only* on ls *) match s with
if ls_equal s ls then | Tslsymbol s when ls_equal s ls ->
Ident.Sattr.singleton (create_attribute "induction") Some attr_ind
else Ident.Sattr.empty) | _ -> None
in in
Trans.compose (Ind_itp.revert_tr_symbol ?tr [Tslsymbol ls]) Trans.compose (Ind_itp.revert_tr_symbol ~tr [Tslsymbol ls])
(Trans.store induction_ty_lex) (Trans.store induction_ty_lex)
let () = wrap_and_register let () = wrap_and_register
......
...@@ -224,21 +224,31 @@ let induction_l attr induct task = match task with ...@@ -224,21 +224,31 @@ let induction_l attr induct task = match task with
with Ind_not_found -> [task] end with Ind_not_found -> [task] end
| _ -> assert false | _ -> assert false
let induction_on_hyp attr b h = let induction_on_hyp attr b h list_hyp_opt =
Trans.compose (Ind_itp.revert_tr_symbol [Tsprsymbol h]) let l = match list_hyp_opt with
| None -> [Tsprsymbol h]
| Some l -> Tsprsymbol h :: l in
let tr x = match x with
| Tsprsymbol pr when Decl.pr_equal pr h -> Some attr
| _ -> None in
Trans.compose (Ind_itp.revert_tr_symbol ~tr l)
(Trans.store (induction_l attr b)) (Trans.store (induction_l attr b))
let () = wrap_and_register let () = wrap_and_register
~desc:"induction_arg_pr <name>@ \ ~desc:"induction_arg_pr <name>@ \
performs@ 'induction_pr'@ on@ the@ given@ premise." performs@ 'induction_pr'@ on@ the@ given@ premise. Optional@ <with_gen>@ \
arguments@ are@ the@ elements@ to@ be@ generalized@."
"induction_arg_pr" "induction_arg_pr"
(Tprsymbol Ttrans_l) (induction_on_hyp attr_ind true) (Tprsymbol (Topt ("with_gen", Tlist Ttrans_l)))
(induction_on_hyp attr_ind true)
let () = wrap_and_register let () = wrap_and_register
~desc:"inversion_arg_pr <name>@ \ ~desc:"inversion_arg_pr <name>@ \
performs@ 'inversion_pr'@ on@ the@ given@ premise." performs@ 'inversion_pr'@ on@ the@ given@ premise. Optional@ <with_gen>@ \
arguments@ are@ the@ elements@ to@ be@ generalized@."
"inversion_arg_pr" "inversion_arg_pr"
(Tprsymbol Ttrans_l) (induction_on_hyp attr_inv false) (Tprsymbol (Topt ("with_gen", Tlist Ttrans_l)))
(induction_on_hyp attr_inv false)
let () = let () =
Trans.register_transform_l "induction_pr" Trans.register_transform_l "induction_pr"
......
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