helm/ocaml/tactics/tacticals.ml

   1 (* Copyright (C) 2002, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 open CicReduction
  27 open ProofEngineTypes
  28 open UriManager
  29
  30 (** DEBUGGING *)
  31
  32   (** perform debugging output? *)
  33 let debug = false
  34 let debug_print = fun _ -> ()
  35
  36   (** debugging print *)
  37 let warn s =
  38   if debug then
  39     debug_print ("TACTICALS WARNING: " ^ s)
  40
  41
  42 (** TACTIC{,AL}S *)
  43
  44   (* not a tactical, but it's used only here (?) *)
  45
  46 let id_tac =
  47  let tac (proof,goal) = (proof,[goal])
  48  in
  49   mk_tactic tac
  50
  51   (**
  52     naive implementation of ORELSE tactical, try a sequence of tactics in turn:
  53     if one fails pass to the next one and so on, eventually raises (failure "no
  54     tactics left")
  55     TODO warning: not tail recursive due to "try .. with" boxing
  56
  57     Galla: is this exactly Coq's "First"?
  58
  59   *)
  60 let try_tactics ~tactics =
  61  let rec try_tactics ~(tactics: (string * tactic) list) status =
  62   warn "in Tacticals.try_tactics";
  63   match tactics with
  64   | (descr, tac)::tactics ->
  65       warn ("Tacticals.try_tactics IS TRYING " ^ descr);
  66       (try
  67         let res = apply_tactic tac status in
  68         warn ("Tacticals.try_tactics: " ^ descr ^ " succedeed!!!");
  69         res
  70        with
  71         e ->
  72          match e with
  73             (Fail _)
  74           | (CicTypeChecker.TypeCheckerFailure _)
  75           | (CicUnification.UnificationFailure _) ->
  76               warn (
  77                 "Tacticals.try_tactics failed with exn: " ^
  78                 Printexc.to_string e);
  79               try_tactics ~tactics status
  80         | _ -> raise e (* [e] must not be caught ; let's re-raise it *)
  81       )
  82   | [] -> raise (Fail "try_tactics: no tactics left")
  83  in
  84   mk_tactic (try_tactics ~tactics)
  85
  86
  87 let thens ~start ~continuations =
  88  let thens ~start ~continuations status =
  89  let (proof,new_goals) = apply_tactic start status in
  90   try
  91    List.fold_left2
  92     (fun (proof,goals) goal tactic ->
  93       let (proof',new_goals') = apply_tactic tactic (proof,goal) in
  94        (proof',goals@new_goals')
  95     ) (proof,[]) new_goals continuations
  96   with
  97    Invalid_argument _ -> raise (Fail "thens: wrong number of new goals")
  98  in
  99   mk_tactic (thens ~start ~continuations )
 100
 101
 102 let then_ ~start ~continuation =
 103  let then_ ~start ~continuation status =
 104  let (proof,new_goals) = apply_tactic start status in
 105   List.fold_left
 106    (fun (proof,goals) goal ->
 107      let (proof',new_goals') = apply_tactic continuation (proof,goal) in
 108       (proof',goals@new_goals')
 109    ) (proof,[]) new_goals
 110  in
 111   mk_tactic (then_ ~start ~continuation)
 112
 113 let rec seq ~tactics =
 114   match tactics with
 115   | [] -> assert false
 116   | [tac] -> tac
 117   | hd :: tl -> then_ ~start:hd ~continuation:(seq ~tactics:tl)
 118
 119 (* TODO: x debug: i due tatticali seguenti non contano quante volte hanno applicato la tattica *)
 120
 121 (* This keep on appling tactic until it fails *)
 122 (* When <tactic> generates more than one goal, you have a tree of
 123    application on the tactic, repeat_tactic works in depth on this tree *)
 124
 125 let repeat_tactic ~tactic =
 126  let rec repeat_tactic ~tactic status =
 127   warn "in repeat_tactic";
 128   try let (proof, goallist) = apply_tactic tactic status in
 129    let rec step proof goallist =
 130     match goallist with
 131        [] -> (proof, [])
 132      | head::tail ->
 133         let (proof', goallist') = repeat_tactic ~tactic (proof, head) in
 134          let (proof'', goallist'') = step proof' tail in
 135           proof'', goallist'@goallist''
 136    in
 137     step proof goallist
 138   with
 139    (Fail _) as e ->
 140     warn ("Tacticals.repeat_tactic failed after nth time with exception: " ^ Printexc.to_string e) ;
 141     apply_tactic id_tac status
 142  in
 143   mk_tactic (repeat_tactic ~tactic)
 144 ;;
 145
 146
 147
 148 (* This tries to apply tactic n times *)
 149 let do_tactic ~n ~tactic =
 150  let rec do_tactic ~n ~tactic status =
 151   warn "in do_tactic";
 152   try
 153    let (proof, goallist) =
 154     if (n>0) then apply_tactic tactic status
 155              else apply_tactic id_tac status in
 156 (*             else (proof, []) in *)
 157 (* perche' non va bene questo? stessa questione di ##### ? *)
 158    let rec step proof goallist =
 159     match goallist with
 160        [] -> (proof, [])
 161      | head::tail ->
 162         let (proof', goallist') =
 163          do_tactic ~n:(n-1) ~tactic (proof, head) in
 164         let (proof'', goallist'') = step proof' tail in
 165          proof'', goallist'@goallist''
 166    in
 167     step proof goallist
 168   with
 169    (Fail _) as e ->
 170     warn ("Tacticals.do_tactic failed after nth time with exception: " ^ Printexc.to_string e) ;
 171     apply_tactic id_tac status
 172  in
 173   mk_tactic (do_tactic ~n ~tactic)
 174 ;;
 175
 176
 177
 178 (* This applies tactic and catches its possible failure *)
 179 let try_tactic ~tactic =
 180  let rec try_tactic ~tactic status =
 181   warn "in Tacticals.try_tactic";
 182   try
 183    apply_tactic tactic status
 184   with
 185    (Fail _) as e ->
 186     warn ( "Tacticals.try_tactic failed with exn: " ^ Printexc.to_string e);
 187     apply_tactic id_tac status
 188  in
 189   mk_tactic (try_tactic ~tactic)
 190 ;;
 191
 192 let fail = mk_tactic (fun _ -> raise (Fail "fail tactical"))
 193
 194 (* This tries tactics until one of them doesn't _solve_ the goal *)
 195 (* TODO: si puo' unificare le 2(due) chiamate ricorsive? *)
 196 let solve_tactics ~tactics =
 197  let rec solve_tactics ~(tactics: (string * tactic) list) status =
 198   warn "in Tacticals.solve_tactics";
 199   match tactics with
 200   | (descr, currenttactic)::moretactics ->
 201       warn ("Tacticals.solve_tactics is trying " ^ descr);
 202       (try
 203         let (proof, goallist) = apply_tactic currenttactic status in
 204          match goallist with
 205             [] -> warn ("Tacticals.solve_tactics: " ^ descr ^
 206                    " solved the goal!!!");
 207 (* questo significa che non ci sono piu' goal, o che current_tactic non ne
 208    ha aperti di nuovi? (la 2a!) #####
 209    nel secondo caso basta per dire che solve_tactics has solved the goal? (si!) *)
 210                   (proof, goallist)
 211           | _ -> warn ("Tacticals.solve_tactics: try the next tactic");
 212                  solve_tactics ~tactics:(moretactics) status
 213        with
 214         (Fail _) as e ->
 215          warn ("Tacticals.solve_tactics: current tactic failed with exn: " ^
 216           Printexc.to_string e);
 217          solve_tactics ~tactics status
 218       )
 219   | [] -> raise (Fail "solve_tactics cannot solve the goal");
 220           apply_tactic id_tac status
 221  in
 222   mk_tactic (solve_tactics ~tactics)
 223 ;;
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234   (** tattica di prova per debuggare i tatticali *)
 235 (*
 236 let thens' ~start ~continuations status =
 237  let (proof,new_goals) = start status in
 238   try
 239    List.fold_left2
 240     (fun (proof,goals) goal tactic ->
 241       let (proof',new_goals') = tactic (proof,goal) in
 242        (proof',goals@new_goals')
 243     ) (proof,[]) new_goals continuations
 244   with
 245    Invalid_argument _ -> raise (Fail "thens: wrong number of new goals")
 246
 247 let prova_tac =
 248  let apply_T_tac status =
 249   let (proof, goal) = status in
 250   let curi,metasenv,pbo,pty = proof in
 251   let metano,context,gty = CicUtil.lookup_meta goal metasenv in
 252    let rel =
 253     let rec find n =
 254      function
 255         [] -> assert false
 256       | (Some (Cic.Name name,_))::_ when name = "T" -> n
 257       | _::tl -> find (n+1) tl
 258     in
 259      debug_print ("eseguo find");
 260      find 1 context
 261    in
 262     debug_print ("eseguo apply");
 263     apply_tac ~term:(Cic.Rel rel) status
 264  in
 265 (*  do_tactic ~n:2 *)
 266   repeat_tactic
 267    ~tactic:
 268     (then_
 269       ~start:(intros_tac ~name:"pippo")
 270       ~continuation:(thens' ~start:apply_T_tac ~continuations:[id_tac ; apply_tac ~term:(Cic.Rel 1)]))
 271 (* id_tac *)
 272 ;;
 273 *)
 274
 275