let s = status#stack in
match s with
| [] -> fail (lazy "There's nothing to prove")
- | (g1, _, k, tag1, _) :: tl ->
+ | (g1, _, _k, _tag1, _) :: _tl ->
let goals = filter_open g1 in
match goals with
[] -> fail (lazy "No goals under focus")
- | loc::tl ->
+ | loc::_tl ->
let goal = goal_of_loc (loc) in
goal ;;
let extract_conclusion_type status goal =
let gty = get_goalty status goal in
let ctx = ctx_of gty in
- let status,gty = term_of_cic_term status gty ctx in
- gty
+ term_of_cic_term status gty ctx
;;
let alpha_eq_tacterm_kerterm ty t status goal =
| (g,t,k,tag,p)::tl ->
let rec remove_volatile = function
[] -> []
- | (k,v as hd')::tl' ->
+ | (k,_v as hd')::tl' ->
let re = Str.regexp "volatile_.*" in
if Str.string_match re k 0 then
remove_volatile tl'
status#set_stack ((g,t,k,tag,newp)::tl)
;;
+let add_parameter_tac key value status =
+ match status#stack with
+ [] -> status
+ | (g,t,k,tag,p) :: tl -> status#set_stack ((g,t,k,tag,(key,value)::p)::tl)
+;;
+
+
(* LCF-like tactic that checks whether the conclusion of the sequent of the given goal is a product, checks that
the type of the conclusion's bound variable is the same as t1 and then uses an exact_tac with
\lambda id: t1. ?. If a t2 is given it checks that t1 ~_{\beta} t2 and uses and exact_tac with \lambda id: t2. ?
*)
-let lambda_abstract_tac id t1 t2 status goal =
+let lambda_abstract_tac id t1 status goal =
match extract_conclusion_type status goal with
- | NCic.Prod (_,t,_) ->
+ | status,NCic.Prod (_,t,_) ->
if alpha_eq_tacterm_kerterm t1 t status goal then
- match t2 with
- | None ->
- let (_,_,t1) = t1 in
- block_tac [exact_tac ("",0,(Ast.Binder (`Lambda,(Ast.Ident (id,None),Some t1),Ast.Implicit
- `JustOne))); clear_volatile_params_tac] status
- | Some t2 ->
- let status,res = are_convertible t1 t2 status goal in
- if res then
- let (_,_,t2) = t2 in
- block_tac [exact_tac ("",0,(Ast.Binder (`Lambda,(Ast.Ident (id,None),Some t2),Ast.Implicit
- `JustOne))); clear_volatile_params_tac] status
- else
- raise NotEquivalentTypes
+ let (_,_,t1) = t1 in
+ block_tac [exact_tac ("",0,(Ast.Binder (`Lambda,(Ast.Ident (id,None),Some t1),Ast.Implicit
+ `JustOne))); clear_volatile_params_tac;
+ add_parameter_tac "volatile_newhypo" id] status
else
raise FirstTypeWrong
| _ -> raise NotAProduct
-let assume name ty eqty status =
+let assume name ty status =
let goal = extract_first_goal_from_status status in
- try lambda_abstract_tac name ty eqty status goal
+ try lambda_abstract_tac name ty status goal
with
| NotAProduct -> fail (lazy "You can't assume without an universal quantification")
| FirstTypeWrong -> fail (lazy "The assumed type is wrong")
| NotEquivalentTypes -> fail (lazy "The two given types are not equivalent")
;;
-let suppose t1 id t2 status =
+let suppose t1 id status =
let goal = extract_first_goal_from_status status in
- try lambda_abstract_tac id t1 t2 status goal
+ try lambda_abstract_tac id t1 status goal
with
| NotAProduct -> fail (lazy "You can't suppose without a logical implication")
| FirstTypeWrong -> fail (lazy "The supposed proposition is different from the premise")
;;
let assert_tac t1 t2 status goal continuation =
- let t = extract_conclusion_type status goal in
+ let status,t = extract_conclusion_type status goal in
if alpha_eq_tacterm_kerterm t1 t status goal then
match t2 with
| None -> continuation
| Some t2 ->
- let status,res = are_convertible t1 t2 status goal in
+ let _status,res = are_convertible t1 t2 status goal in
if res then continuation
else
raise NotEquivalentTypes
let status_parameter key status =
match status#stack with
[] -> ""
- | (g,t,k,tag,p)::_ -> try List.assoc key p with _ -> ""
+ | (_g,_t,_k,_tag,p)::_ -> try List.assoc key p with _ -> ""
;;
let beta_rewriting_step t status =
let ctx = status_parameter "volatile_context" status in
- if ctx <> "beta_rewrite" then fail (lazy "Invalid use of 'or equivalently'")
+ if ctx <> "beta_rewrite" then
+ (
+ let newhypo = status_parameter "volatile_newhypo" status in
+ if newhypo = "" then
+ fail (lazy "Invalid use of 'that is equivalent to'")
+ else
+ change_tac ~where:("",0,(None,[newhypo,Ast.UserInput],None)) ~with_what:t status
+ )
else
change_tac ~where:("",0,(None,[],Some
Ast.UserInput)) ~with_what:t status
else status (* Nothing to push *)
| _ -> status
-let add_parameter_tac key value status =
- match status#stack with
- [] -> status
- | (g,t,k,tag,p) :: tl -> status#set_stack ((g,t,k,tag,(key,value)::p)::tl)
-;;
-
-let we_need_to_prove t id t1 status =
+let we_need_to_prove t id status =
let goal = extract_first_goal_from_status status in
match id with
| None ->
(
- match t1 with
- | None -> (* We need to prove t *)
- (
- try assert_tac t None status goal (add_parameter_tac "volatile_context" "beta_rewrite" status)
- with
- | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
- )
- | Some t1 -> (* We need to prove t or equivalently t1 *)
- (
- try assert_tac t (Some t1) status goal (block_tac [change_tac ~where:("",0,(None,[],Some
- Ast.UserInput))
- ~with_what:t1;
- add_parameter_tac "volatile_context"
- "beta_rewrite"] status)
- with
- | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
- | NotEquivalentTypes -> fail (lazy "The given propositions are not equivalent")
- )
+ try assert_tac t None status goal (add_parameter_tac "volatile_context" "beta_rewrite" status)
+ with
+ | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
)
| Some id ->
(
- match t1 with
- (* We need to prove t (id) *)
- | None -> block_tac [clear_volatile_params_tac; cut_tac t; branch_tac; shift_tac; intro_tac id; merge_tac; branch_tac;
- push_goals_tac
+ block_tac [clear_volatile_params_tac; cut_tac t; branch_tac; shift_tac; intro_tac id; merge_tac; branch_tac;
+ push_goals_tac; add_parameter_tac "volatile_context" "beta_rewrite"
] status
- (* We need to prove t (id) or equivalently t1 *)
- | Some t1 -> block_tac [clear_volatile_params_tac; cut_tac t; branch_tac ; change_tac ~where:("",0,(None,[],Some
- Ast.UserInput))
- ~with_what:t1; shift_tac; intro_tac id; merge_tac;
- branch_tac; push_goals_tac
- ]
- status
)
;;
-let by_just_we_proved just ty id ty' status =
+let by_just_we_proved just ty id status =
let goal = extract_first_goal_from_status status in
- let wrappedjust = just in
let just = mk_just status goal just in
match id with
| None ->
- (match ty' with
- | None -> (* just we proved P done *)
- (
- try
- assert_tac ty None status goal (bydone wrappedjust status)
- with
- | FirstTypeWrong -> fail (lazy "The given proposition is not the same as the conclusion")
- | NotEquivalentTypes -> fail (lazy "The given propositions are not equivalent")
- )
- | Some ty' -> (* just we proved P that is equivalent to P' done *)
- (
- try
- assert_tac ty' None status goal (block_tac [change_tac ~where:("",0,(None,[],Some
- Ast.UserInput))
- ~with_what:ty; bydone wrappedjust]
- status )
- with
- | FirstTypeWrong -> fail (lazy "The second proposition is not the same as the conclusion")
- | NotEquivalentTypes -> fail (lazy "The given propositions are not equivalent")
- )
- )
+ assert_tac ty None status goal (block_tac [clear_volatile_params_tac; add_parameter_tac
+ "volatile_context" "beta_rewrite"] status)
| Some id ->
(
- match ty' with
- | None -> block_tac [cut_tac ty; branch_tac; just; shift_tac; intro_tac id; merge_tac;
- clear_volatile_params_tac ] status
- | Some ty' -> block_tac [cut_tac ty; branch_tac; just; shift_tac; intro_tac id; change_tac
- ~where:("",0,(None,[id,Ast.UserInput],None)) ~with_what:ty';
- merge_tac; clear_volatile_params_tac] status
+ block_tac [cut_tac ty; branch_tac; just; shift_tac; intro_tac id; merge_tac;
+ clear_volatile_params_tac; add_parameter_tac "volatile_newhypo" id] status
)
;;
in
status#set_stack gstatus
-let thesisbecomes t1 l = we_need_to_prove t1 None l
+let thesisbecomes t1 = we_need_to_prove t1 None
;;
let obtain id t1 status =
let ctx = ctx_of cicgty in
let _,gty = term_of_cic_term status cicgty ctx in
match gty with
+ (* The first term of this Appl should probably be "eq" *)
NCic.Appl [_;_;plhs;_] ->
if alpha_eq_tacterm_kerterm t1 plhs status goal then
add_parameter_tac "volatile_context" "rewrite" status
in
let continuation =
if last_step then
- (*CSC:manca controllo sul fatto che rhs sia convertibile con prhs*)
let todo = [just'] @ (done_continuation status) in
- (* let todo = if mustdot status then List.append todo [dot_tac] else todo *)
- (* in *)
block_tac todo
else
let (_,_,rhs) = rhs in
(* Useful as it does not change the order in the list *)
let rec list_change_assoc k v = function
[] -> []
- | (k',v' as hd) :: tl -> if k' = k then (k',v) :: tl else hd :: (list_change_assoc k v tl)
+ | (k',_v' as hd) :: tl -> if k' = k then (k',v) :: tl else hd :: (list_change_assoc k v tl)
;;
let add_names_to_goals_tac (cl:NCic.constructor list ref) (status:#NTacStatus.tac_status) =
let add_name_to_goal name goal metasenv =
- let (mattrs,ctx,t as conj) = try List.assoc goal metasenv with _ -> assert false in
+ let (mattrs,ctx,t) = try List.assoc goal metasenv with _ -> assert false in
let mattrs = (`Name name) :: (List.filter (function `Name _ -> false | _ -> true) mattrs) in
let newconj = (mattrs,ctx,t) in
list_change_assoc goal newconj metasenv
* the new goals, when they are still under focus *)
match status#stack with
[] -> fail (lazy "Can not add names to an empty stack")
- | (g,_,_,_,_) :: tl ->
+ | (g,_,_,_,_) :: _tl ->
let rec sublist n = function
[] -> []
| hd :: tl -> if n = 0 then [] else hd :: (sublist (n-1) tl)
let t1 = txt, len, Ast.Appl [t1; Ast.Implicit `Vector] in
let indtyinfo = ref None in
let sort = ref (NCic.Rel 1) in
- let cl = ref [] in
+ let cl = ref [] in (* this is a ref on purpose, as the block of code after sort_of_goal_tac in
+ block_tac acts as a block of asynchronous code, in which cl gets modified with the info retrieved
+ with analize_indty_tac, and later used to label each new goal with a costructor name. Using a
+ plain list this doesn't seem to work, as add_names_to_goals_tac would immediately act on an empty
+ list, instead of acting on the list of constructors *)
try
assert_tac t2 None status goal (block_tac [
analyze_indty_tac ~what:t1 indtyinfo;
| FirstTypeWrong -> fail (lazy "What you want to prove is different from the conclusion")
;;
-let byinduction t1 id = suppose t1 id None ;;
+let byinduction t1 id status =
+ let ctx = status_parameter "context" status in
+ if ctx <> "induction" then fail (lazy "You can't use this tactic outside of an induction context")
+ else suppose t1 id status
+;;
let name_of_conj conj =
let mattrs,_,_ = conj in
let has_focused_goal status =
match status#stack with
[] -> false
- | ([],_,_,_,_) :: tl -> false
+ | ([],_,_,_,_) :: _tl -> false
| _ -> true
;;
match l with
[] -> [id_tac]
| (id,ty)::tl ->
- (try_tac (assume id ("",0,ty) None)) :: (aux tl)
+ (try_tac (assume id ("",0,ty))) :: (aux tl)
in
aux l
in
projects / helm.git / blobdiff