(* proof assistant status *)
-let proof = ref (None : proof)
-let goal = ref (None : goal)
+let proof = ref (None : proof option)
+let goal = ref (None : goal option)
-let apply_tactic ~tactic:tactic =
- let (newproof, newgoal) = tactic ~status:(!proof, !goal) in
- proof := newproof;
- goal := newgoal
+let apply_or_can_apply_tactic ~try_only ~tactic =
+ match !proof,!goal with
+ None,_
+ | _,None -> assert false
+ | Some proof', Some goal' ->
+ let (newproof, newgoals) = tactic ~status:(proof', goal') in
+ if not try_only then
+ begin
+ proof := Some newproof;
+ goal :=
+ (match newgoals, newproof with
+ goal::_, _ -> Some goal
+ | [], (_,(goal,_,_)::_,_,_) ->
+ (* the tactic left no open goal ; let's choose the first open goal *)
+(*CSC: here we could implement and use a proof-tree like notion... *)
+ Some goal
+ | _, _ -> None)
+ end
+;;
+
+let apply_tactic = apply_or_can_apply_tactic ~try_only:false;;
+
+let can_apply_tactic ~tactic =
+ try
+ apply_or_can_apply_tactic ~try_only:true ~tactic ;
+ true
+ with
+ Fail _ -> false
+;;
(* metas_in_term term *)
(* Returns the ordered list of the metas that occur in [term]. *)
let module C = Cic in
let rec aux =
function
- C.Rel _
- | C.Var _ -> []
+ C.Rel _ -> []
| C.Meta (n,_) -> [n]
| C.Sort _
| C.Implicit -> []
| C.Lambda (_,s,t) -> (aux s) @ (aux t)
| C.LetIn (_,s,t) -> (aux s) @ (aux t)
| C.Appl l -> List.fold_left (fun i t -> i @ (aux t)) [] l
- | C.Const _
- | C.MutInd _
- | C.MutConstruct _ -> []
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst)
+ | C.MutInd (_,_,exp_named_subst)
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_left (fun i (_,t) -> i @ (aux t)) [] exp_named_subst
+ | C.MutCase (_,_,outt,t,pl) ->
(aux outt) @ (aux t) @
(List.fold_left (fun i t -> i @ (aux t)) [] pl)
- | C.Fix (i,fl) ->
+ | C.Fix (_,fl) ->
List.fold_left (fun i (_,_,ty,bo) -> i @ (aux bo) @ (aux ty)) [] fl
- | C.CoFix (i,fl) ->
+ | C.CoFix (_,fl) ->
List.fold_left (fun i (_,ty,bo) -> i @ (aux bo) @ (aux ty)) [] fl
in
let metas = aux term in
(* are efficiency reasons. *)
let perforate context term ty =
let module C = Cic in
- let newmeta = new_meta !proof in
- match !proof with
- None -> assert false
- | Some (uri,metasenv,bo,gty) ->
+ match !proof with
+ None -> assert false
+ | Some (uri,metasenv,bo,gty as proof') ->
+ let newmeta = new_meta proof' in
(* We push the new meta at the end of the list for pretty-printing *)
(* purposes: in this way metas are ordered. *)
let metasenv' = metasenv@[newmeta,context,ty] in
(*CSC: ma si potrebbe ovviare al problema. Ma non credo *)
(*CSC: che si guadagni nulla in fatto di efficienza. *)
let replace =
- ProofEngineReduction.replace
- ~equality:(ProofEngineReduction.syntactic_equality)
- ~what:term' ~with_what:term
+ ProofEngineReduction.replace ~equality:(=) ~what:term' ~with_what:term
in
let ty' = replace ty in
let context' =
proof := Some (curi,metasenv',pbo,pty) ;
goal := Some metano
-exception NotConvertible
-
-(*CSC: Bug (or feature?). [input] is parsed in the context of the goal, *)
-(*CSC: while [goal_input] can have a richer context (because of binders) *)
-(*CSC: So it is _NOT_ possible to use those binders in the [input] term. *)
-(*CSC: Is that evident? Is that right? Or should it be changed? *)
-let change ~goal_input ~input =
- let curi,metasenv,pbo,pty =
- match !proof with
- None -> assert false
- | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty
- in
- let metano,context,ty =
- match !goal with
- None -> assert false
- | Some metano -> List.find (function (m,_,_) -> m=metano) metasenv
- in
- (* are_convertible works only on well-typed terms *)
- ignore (CicTypeChecker.type_of_aux' metasenv context input) ;
- if CicReduction.are_convertible context goal_input input then
- begin
- let replace =
- ProofEngineReduction.replace
- ~equality:(==) ~what:goal_input ~with_what:input
- in
- let ty' = replace ty in
- let context' =
- List.map
- (function
- Some (name,Cic.Def t) -> Some (name,Cic.Def (replace t))
- | Some (name,Cic.Decl t) -> Some (name,Cic.Decl (replace t))
- | None -> None
- ) context
- in
- let metasenv' =
- List.map
- (function
- (n,_,_) when n = metano -> (metano,context',ty')
- | _ as t -> t
- ) metasenv
- in
- proof := Some (curi,metasenv',pbo,pty) ;
- goal := Some metano
- end
- else
- raise NotConvertible
-
(************************************************************)
(* Tactics defined elsewhere *)
(************************************************************)
(* primitive tactics *)
+let can_apply term = can_apply_tactic (PrimitiveTactics.apply_tac ~term)
let apply term = apply_tactic (PrimitiveTactics.apply_tac ~term)
let intros () =
apply_tactic (PrimitiveTactics.intros_tac ~name:(fresh_name ()))
let cut term = apply_tactic (PrimitiveTactics.cut_tac ~term)
let letin term = apply_tactic (PrimitiveTactics.letin_tac ~term)
let exact term = apply_tactic (PrimitiveTactics.exact_tac ~term)
-let elim_intros_simpl term =
- apply_tactic (PrimitiveTactics.elim_intros_simpl_tac ~term)
+let elim_simpl_intros term =
+ apply_tactic (PrimitiveTactics.elim_simpl_intros_tac ~term)
+let change ~goal_input:what ~input:with_what =
+ apply_tactic (PrimitiveTactics.change_tac ~what ~with_what)
(* structural tactics *)
let elim_type term = apply_tactic (Ring.elim_type_tac ~term)
let ring () = apply_tactic Ring.ring_tac
+let fourier () = apply_tactic FourierR.fourier_tac
+let rewrite_simpl term = apply_tactic (FourierR.rewrite_simpl_tac ~term)
+
+let reflexivity () = apply_tactic VariousTactics.reflexivity_tac
+let symmetry () = apply_tactic VariousTactics.symmetry_tac
+let transitivity term = apply_tactic (VariousTactics.transitivity_tac ~term)
+
+let left () = apply_tactic VariousTactics.left_tac
+let right () = apply_tactic VariousTactics.right_tac
+
+let assumption () = apply_tactic VariousTactics.assumption_tac
+(*
+let prova_tatticali () = apply_tactic Tacticals.prova_tac
+*)
projects / helm.git / blobdiff