components/tactics/destructTactic.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 (* $Id$ *)
  27
  28 module C = Cic
  29 module U = UriManager
  30 module P = PrimitiveTactics
  31 module T = Tacticals
  32 module CR = CicReduction
  33 module PST = ProofEngineStructuralRules
  34 module PET = ProofEngineTypes
  35 module CTC = CicTypeChecker
  36 module CU = CicUniv
  37 module S = CicSubstitution
  38 module RT = ReductionTactics
  39 module PEH = ProofEngineHelpers
  40 module ET = EqualityTactics
  41 module DTI = DoubleTypeInference
  42 module FNG = FreshNamesGenerator
  43
  44 let debug = false
  45 let debug_print =
  46   if debug then (fun x -> prerr_endline (Lazy.force x)) else (fun _ -> ())
  47
  48 (* term ha tipo t1=t2; funziona solo se t1 e t2 hanno in testa costruttori
  49 diversi *)
  50
  51 let discriminate_tac ~term =
  52  let true_URI =
  53   match LibraryObjects.true_URI () with
  54      Some uri -> uri
  55    | None -> raise (PET.Fail (lazy "You need to register the default \"true\" definition first. Please use the \"default\" command")) in
  56  let false_URI =
  57   match LibraryObjects.false_URI () with
  58      Some uri -> uri
  59    | None -> raise (PET.Fail (lazy "You need to register the default \"false\" definition first. Please use the \"default\" command")) in
  60  let fail msg = raise (PET.Fail (lazy ("Discriminate: " ^ msg))) in
  61  let find_discriminating_consno t1 t2 =
  62    let rec aux t1 t2 =
  63      match t1, t2 with
  64      | C.MutConstruct _, C.MutConstruct _ when t1 = t2 -> None
  65      | C.Appl ((C.MutConstruct _ as constr1) :: args1),
  66        C.Appl ((C.MutConstruct _ as constr2) :: args2)
  67        when constr1 = constr2 ->
  68          let rec aux_list l1 l2 =
  69            match l1, l2 with
  70            | [], [] -> None
  71            | hd1 :: tl1, hd2 :: tl2 ->
  72                (match aux hd1 hd2 with
  73                | None -> aux_list tl1 tl2
  74                | Some _ as res -> res)
  75            | _ -> (* same constructor applied to a different number of args *)
  76                assert false
  77          in
  78          aux_list args1 args2
  79      | ((C.MutConstruct (_,_,consno1,subst1)),
  80        (C.MutConstruct (_,_,consno2,subst2)))
  81      | ((C.MutConstruct (_,_,consno1,subst1)),
  82        (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _)))
  83      | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)),
  84        (C.MutConstruct (_,_,consno2,subst2)))
  85      | ((C.Appl ((C.MutConstruct (_,_,consno1,subst1)) :: _)),
  86        (C.Appl ((C.MutConstruct (_,_,consno2,subst2)) :: _)))
  87        when (consno1 <> consno2) || (subst1 <> subst2) ->
  88          Some consno2
  89      | _ -> fail "not a discriminable equality"
  90    in
  91    aux t1 t2
  92  in
  93  let mk_branches_and_outtype turi typeno consno context args =
  94     (* a list of "True" except for the element in position consno which
  95      * is "False" *)
  96     match fst (CicEnvironment.get_obj CU.empty_ugraph turi) with
  97     | C.InductiveDefinition (ind_type_list,_,paramsno,_)  ->
  98         let _,_,rty,constructor_list = List.nth ind_type_list typeno in
  99         let false_constr_id,_ = List.nth constructor_list (consno - 1) in
 100         let branches =
 101          List.map
 102            (fun (id,cty) ->
 103              (* dubbio: e' corretto ridurre in questo context ??? *)
 104              let red_ty = CR.whd context cty in
 105              let rec aux t k =
 106                match t with
 107                | C.Prod (_,_,target) when (k <= paramsno) ->
 108                    S.subst (List.nth args (k-1))
 109                      (aux target (k+1))
 110                | C.Prod (binder,source,target) when (k > paramsno) ->
 111                    C.Lambda (binder, source, (aux target (k+1)))
 112                | _ ->
 113                    if (id = false_constr_id)
 114                    then (C.MutInd(false_URI,0,[]))
 115                    else (C.MutInd(true_URI,0,[]))
 116              in
 117              (S.lift 1 (aux red_ty 1)))
 118            constructor_list in
 119         let outtype =
 120          let seed = ref 0 in
 121          let rec mk_lambdas rev_left_args =
 122           function
 123              0, args, C.Prod (_,so,ta) ->
 124               C.Lambda
 125                (C.Name (incr seed; "x" ^ string_of_int !seed),
 126                so,
 127                mk_lambdas rev_left_args (0,args,ta))
 128            | 0, args, C.Sort _ ->
 129               let rec mk_rels =
 130                function
 131                   0 -> []
 132                 | n -> C.Rel n :: mk_rels (n - 1) in
 133               let argsno = List.length args in
 134                C.Lambda
 135                 (C.Name "x",
 136                  (if argsno + List.length rev_left_args > 0 then
 137                    C.Appl
 138                     (C.MutInd (turi, typeno, []) ::
 139                      (List.map
 140                       (S.lift (argsno + 1))
 141                       (List.rev rev_left_args)) @
 142                      mk_rels argsno)
 143                   else
 144                    C.MutInd (turi,typeno,[])),
 145                  C.Sort C.Prop)
 146            | 0, _, _ -> assert false (* seriously screwed up *)
 147            | n, he::tl, C.Prod (_,_,ta) ->
 148               mk_lambdas (he::rev_left_args)(n-1,tl,S.subst he ta)
 149            | n,_,_ ->
 150               assert false (* we should probably reduce in some context *)
 151          in
 152           mk_lambdas [] (paramsno, args, rty)
 153         in
 154          branches, outtype
 155     | _ -> assert false
 156  in
 157  let discriminate'_tac ~term status =
 158   let (proof, goal) = status in
 159   let _,metasenv,_subst,_,_, _ = proof in
 160   let _,context,_ = CicUtil.lookup_meta goal metasenv in
 161   let termty,_ =
 162     CTC.type_of_aux' metasenv context term CU.empty_ugraph
 163   in
 164   match termty with
 165    | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]
 166      when LibraryObjects.is_eq_URI equri ->
 167       let turi,typeno,exp_named_subst,args =
 168         match tty with
 169         | (C.MutInd (turi,typeno,exp_named_subst)) ->
 170             turi,typeno,exp_named_subst,[]
 171         | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::args)) ->
 172             turi,typeno,exp_named_subst,args
 173         | _ -> fail "not a discriminable equality"
 174       in
 175       let consno =
 176         match find_discriminating_consno t1 t2 with
 177         | Some consno -> consno
 178         | None -> fail "discriminating terms are structurally equal"
 179       in
 180       let branches,outtype =
 181        mk_branches_and_outtype turi typeno consno context args
 182       in
 183       PET.apply_tactic
 184        (T.then_
 185          ~start:(EliminationTactics.elim_type_tac (C.MutInd (false_URI, 0, [])))
 186          ~continuation:
 187            (T.then_
 188              ~start:
 189                (RT.change_tac
 190                  ~pattern:(PET.conclusion_pattern None)
 191                  (fun _ m u ->
 192                    C.Appl [
 193                      C.Lambda ( C.Name "x", tty,
 194                        C.MutCase (turi, typeno, outtype, (C.Rel 1), branches));
 195                      t2 ],
 196                    m, u))
 197              ~continuation:
 198                (T.then_
 199                  ~start:
 200                    (ET.rewrite_simpl_tac
 201                      ~direction:`RightToLeft
 202                      ~pattern:(PET.conclusion_pattern None)
 203                      term [])
 204                  ~continuation:
 205                    (IntroductionTactics.constructor_tac ~n:1)))) status
 206     | _ -> fail "not an equality"
 207   in
 208   PET.mk_tactic (discriminate'_tac ~term)
 209
 210 let exn_noneq =
 211   PET.Fail (lazy "Injection: not an equality")
 212 let exn_nothingtodo =
 213   PET.Fail (lazy "Nothing to do")
 214 let exn_discrnonind =
 215   PET.Fail (lazy "Discriminate: object is not an Inductive Definition: it's imposible")
 216 let exn_injwronggoal =
 217   PET.Fail (lazy "Injection: goal after cut is not correct")
 218 let exn_noneqind =
 219   PET.Fail (lazy "Injection: not an equality over elements of an inductive type")
 220
 221 let pp ctx t =
 222   let names = List.map (function Some (n,_) -> Some n | None -> None) ctx in
 223   CicPp.pp t names
 224
 225 let clear_term first_time lterm =
 226    let clear_term status =
 227       let (proof, goal) = status in
 228       let _,metasenv,_subst,_,_, _ = proof in
 229       let _,context,_ = CicUtil.lookup_meta goal metasenv in
 230       let term, metasenv, _ugraph = lterm context metasenv CU.empty_ugraph in
 231       debug_print (lazy ("\nclear di: " ^ pp context term));
 232       debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
 233       let g () = if first_time then raise exn_nothingtodo else T.id_tac in
 234       let tactic = match term with
 235          | C.Rel n ->
 236             begin match List.nth context (pred n) with
 237                | Some (C.Name id, _) ->
 238                   T.if_ ~fail:(g ()) ~start:(PST.clear ~hyps:[id]) ~continuation:T.id_tac
 239                | _ -> assert false
 240             end
 241           | _      -> g ()
 242       in
 243       PET.apply_tactic tactic status
 244    in
 245    PET.mk_tactic clear_term
 246
 247 let simpl_in_term context = function
 248    | Cic.Rel i ->
 249       let name = match List.nth context (pred i) with
 250          | Some (Cic.Name s, Cic.Def _) -> s
 251          | Some (Cic.Name s, Cic.Decl _) -> s
 252          | _ -> assert false
 253       in
 254       RT.simpl_tac ~pattern:(None,[name,Cic.Implicit (Some `Hole)],None)
 255    | _ -> T.id_tac
 256
 257 let mk_fresh_name metasenv context name typ =
 258    let name = C.Name name in
 259    match FNG.mk_fresh_name ~subst:[] metasenv context name ~typ with
 260       | C.Name s    -> s
 261       | C.Anonymous -> assert false
 262
 263 let exists context = function
 264    | C.Rel i -> List.nth context (pred i) <> None
 265    | _       -> true
 266
 267 let rec recur_on_child_tac name =
 268    let recur_on_child status =
 269       let (proof, goal) = status in
 270       let _, metasenv, _subst, _, _, _ = proof in
 271       let _, context, _ = CicUtil.lookup_meta goal metasenv in
 272       debug_print (lazy ("\nrecur_on_child su: " ^ name));
 273       debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
 274       let rec search_name i = function
 275          | []                                      -> T.id_tac
 276          | Some (Cic.Name n, _) :: _ when n = name ->
 277               destruct ~first_time:false (Cic.Rel i)
 278          | _ :: tl -> search_name (succ i) tl
 279       in
 280       PET.apply_tactic (search_name 1 context) status
 281    in
 282    PET.mk_tactic recur_on_child
 283
 284 and injection_tac ~lterm ~i ~continuation =
 285  let give_name seed = function
 286    | C.Name _ as name -> name
 287    | C.Anonymous -> C.Name (incr seed; "y" ^ string_of_int !seed)
 288  in
 289  let rec mk_rels = function | 0 -> [] | n -> C.Rel n :: (mk_rels (n - 1)) in
 290  let injection_tac status =
 291   let (proof, goal) = status in
 292   (* precondizione: t1 e t2 hanno in testa lo stesso costruttore ma
 293    * differiscono (o potrebbero differire?) nell'i-esimo parametro
 294    * del costruttore *)
 295   let _,metasenv,_subst,_,_, _ = proof in
 296   let _,context,_ = CicUtil.lookup_meta goal metasenv in
 297   let term, metasenv, _ugraph = lterm context metasenv CU.empty_ugraph in
 298   let termty,_ =
 299     CTC.type_of_aux' metasenv context term CU.empty_ugraph
 300   in
 301   debug_print (lazy ("\ninjection su : " ^ pp context termty));
 302   match termty with (* an equality *)
 303    | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]
 304     when LibraryObjects.is_eq_URI equri ->
 305       let turi,typeno,ens,params =
 306         match tty with (* some inductive type *)
 307         | C.MutInd (turi,typeno,ens) -> turi,typeno,ens,[]
 308         | C.Appl (C.MutInd (turi,typeno,ens)::params) -> turi,typeno,ens,params
 309         | _ -> raise exn_noneqind
 310       in
 311       let t1',t2',consno = (* sono i due sottotermini che differiscono *)
 312         match t1,t2 with
 313         | C.Appl ((C.MutConstruct (uri1,typeno1,consno1,ens1))::applist1),
 314           C.Appl ((C.MutConstruct (uri2,typeno2,consno2,ens2))::applist2)
 315           when (uri1 = uri2) && (typeno1 = typeno2) &&
 316                (consno1 = consno2) && (ens1 = ens2) ->
 317                (* controllo ridondante *)
 318             List.nth applist1 (pred i),List.nth applist2 (pred i),consno2
 319         | _ -> assert false
 320       in
 321       let tty',_ = CTC.type_of_aux' metasenv context t1' CU.empty_ugraph in
 322       let patterns,outtype =
 323         match fst (CicEnvironment.get_obj CU.empty_ugraph turi) with
 324         | C.InductiveDefinition (ind_type_list,_,paramsno,_)->
 325            let left_params, right_params = HExtlib.split_nth paramsno params in
 326            let _,_,_,constructor_list = List.nth ind_type_list typeno in
 327            let i_constr_id,_ = List.nth constructor_list (consno - 1) in
 328            let patterns =
 329              let seed = ref 0 in
 330              List.map
 331                (function (id,cty) ->
 332                  let reduced_cty = CR.whd context cty in
 333                  let rec aux k = function
 334                    | C.Prod (_,_,tgt) when k <= paramsno ->
 335                        let left = List.nth left_params (k-1) in
 336                        aux (k+1) (S.subst left tgt)
 337                    | C.Prod (binder,source,target) when k > paramsno ->
 338                       let binder' = give_name seed binder in
 339                       C.Lambda (binder',source,(aux (k+1) target))
 340                    | _ ->
 341                      let nr_param_constr = k - paramsno - 1 in
 342                      if id = i_constr_id then C.Rel (k - i)
 343                      else S.lift nr_param_constr t1'
 344                      (* + 1 per liftare anche il lambda aggiunto
 345                       * esternamente al case *)
 346                  in S.lift 1 (aux 1 reduced_cty))
 347                constructor_list
 348            in
 349            (* this code should be taken from cases_tac *)
 350            let outtype =
 351              let seed = ref 0 in
 352              let rec to_lambdas te head =
 353                match CR.whd context te with
 354                | C.Prod (binder,so,ta) ->
 355                    let binder' = give_name seed binder in
 356                    C.Lambda (binder',so,to_lambdas ta head)
 357                | _ -> head
 358              in
 359              let rec skip_prods params te =
 360                match params, CR.whd context te with
 361                | [], _ -> te
 362                | left::tl, C.Prod (_,_,ta) ->
 363                    skip_prods tl (S.subst left ta)
 364                | _, _ -> assert false
 365              in
 366              let abstracted_tty =
 367                let tty =
 368                  List.fold_left (fun x y -> S.subst y x) tty left_params
 369                in
 370                (* non lift, ma subst coi left! *)
 371                match S.lift 1 tty with
 372                | C.MutInd _ as tty' -> tty'
 373                | C.Appl l ->
 374                    let keep,abstract = HExtlib.split_nth (paramsno +1) l in
 375                    let keep = List.map (S.lift paramsno) keep in
 376                    C.Appl (keep@mk_rels (List.length abstract))
 377                | _ -> assert false
 378              in
 379              match ind_type_list with
 380              | [] -> assert false
 381              | (_,_,ty,_)::_ ->
 382                (* this is in general wrong, do as in cases_tac *)
 383                to_lambdas (skip_prods left_params ty)
 384                  (C.Lambda
 385                    (C.Name "cased", abstracted_tty,
 386                      (* here we should capture right parameters *)
 387                      (* 1 for his Lambda, one for the Lambda outside the match
 388                       * and then one for each to_lambda *)
 389                      S.lift (2+List.length right_params) tty'))
 390           in
 391             patterns,outtype
 392         | _ -> raise exn_discrnonind
 393       in
 394       let cutted = C.Appl [C.MutInd (equri,0,[]) ; tty' ; t1' ; t2'] in
 395       let changed =
 396         C.Appl [ C.Lambda (C.Name "x", tty,
 397                   C.MutCase (turi,typeno,outtype,C.Rel 1,patterns)) ; t1]
 398       in
 399       (* check if cutted and changed are well typed and if t1' ~ changed *)
 400       let go_on =
 401         try
 402           let _,g = CTC.type_of_aux' metasenv context  cutted
 403             CU.empty_ugraph
 404           in
 405           let _,g = CTC.type_of_aux' metasenv context changed g in
 406           fst (CR.are_convertible ~metasenv context  t1' changed g)
 407         with
 408         | CTC.TypeCheckerFailure _ -> false
 409       in
 410       if not go_on then begin
 411         HLog.warn "destruct: injection failed";
 412         PET.apply_tactic continuation status
 413       end else
 414         let fill_cut_tac term =
 415            let fill_cut status =
 416                debug_print (lazy "riempio il cut");
 417                let (proof, goal) = status in
 418                let _,metasenv,_subst,_,_, _ = proof in
 419                let _,context,gty = CicUtil.lookup_meta goal metasenv in
 420                let gty = Unshare.unshare gty in
 421                let new_t1' = match gty with
 422                   | (C.Appl (C.MutInd (_,_,_)::_::t::_)) -> t
 423                   | _ -> raise exn_injwronggoal
 424                in
 425                debug_print (lazy ("metto: " ^ pp context changed));
 426                debug_print (lazy ("al posto di: " ^ pp context new_t1'));
 427                debug_print (lazy ("nel goal: " ^ pp context gty));
 428                debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
 429                debug_print (lazy ("e poi rewrite con: "^pp context term));
 430                let tac = T.seq ~tactics:[
 431                   RT.change_tac
 432                      ~pattern:(None, [], Some (PEH.pattern_of ~term:gty [new_t1']))
 433                      (fun _ m u -> changed,m,u);
 434                   ET.rewrite_simpl_tac
 435                      ~direction:`LeftToRight
 436                      ~pattern:(PET.conclusion_pattern None)
 437                      term [];
 438                   ET.reflexivity_tac
 439                ] in
 440                PET.apply_tactic tac status
 441            in
 442            PET.mk_tactic fill_cut
 443         in
 444         debug_print (lazy ("CUT: " ^ pp context cutted));
 445         let name = mk_fresh_name metasenv context "Hcut" cutted in
 446         let mk_fresh_name_callback = PEH.namer_of [Some name] in
 447         debug_print (lazy ("figlio: " ^ name));
 448         let tactic =
 449            T.thens ~start: (P.cut_tac ~mk_fresh_name_callback cutted)
 450                    ~continuations:[
 451                       T.seq ~tactics:[continuation; recur_on_child_tac name];
 452                       fill_cut_tac term
 453                    ]
 454         in
 455         PET.apply_tactic tactic status
 456    | _ -> raise exn_noneq
 457  in
 458   PET.mk_tactic injection_tac
 459
 460 and subst_tac ~lterm ~direction ~where ~continuation =
 461    let subst_tac status =
 462       let (proof, goal) = status in
 463       let _,metasenv,_subst,_,_, _ = proof in
 464       let _,context,_ = CicUtil.lookup_meta goal metasenv in
 465       let term, metasenv, _ugraph = lterm context metasenv CU.empty_ugraph in
 466       debug_print (lazy ("\nsubst " ^ (match direction with `LeftToRight -> "->" | `RightToLeft -> "<-") ^ " di: " ^ pp context term));
 467       let tactic = match where with
 468          | None      ->
 469             debug_print (lazy ("nella conclusione"));
 470             let pattern = PET.conclusion_pattern None in
 471             let tactic = ET.rewrite_tac ~direction ~pattern term [] in
 472             T.then_ ~start:(T.try_tactic ~tactic) ~continuation
 473          | Some name ->
 474             debug_print (lazy ("nella premessa: " ^ name));
 475             let pattern = None, [name, PET.hole], None in
 476             let start = ET.rewrite_tac ~direction ~pattern term [] in
 477             let ok_tactic =
 478                T.seq ~tactics:[continuation; recur_on_child_tac name]
 479             in
 480             debug_print (lazy ("figlio: " ^ name));
 481             T.if_ ~start ~continuation:ok_tactic ~fail:continuation
 482       in
 483       PET.apply_tactic tactic status
 484    in
 485    PET.mk_tactic subst_tac
 486
 487 and destruct ?(simplified = false) ~first_time term =
 488  let are_convertible hd1 hd2 metasenv context =
 489    fst (CR.are_convertible ~metasenv context hd1 hd2 CU.empty_ugraph)
 490  in
 491  let destruct status =
 492   let (proof, goal) = status in
 493   let _,metasenv,_subst, _,_, _ = proof in
 494   let _,context,_ = CicUtil.lookup_meta goal metasenv in
 495   debug_print (lazy ("\ndestruct di: " ^ pp context term));
 496   debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
 497   let termty,_ =
 498     CTC.type_of_aux' metasenv context term CU.empty_ugraph
 499   in
 500   debug_print (lazy ("\ndestruct su: " ^ pp context termty));
 501   let mk_lterm term c m ug =
 502      let distance = List.length c - List.length context in
 503      S.lift distance term, m, ug
 504   in
 505   let lterm = mk_lterm term in
 506   let mk_subst_chain direction index with_what what =
 507      let k = match term with C.Rel i -> i | _ -> -1 in
 508      let rec traverse_context first_time j = function
 509         | [] ->
 510            let continuation =
 511               T.seq ~tactics:[
 512                  clear_term first_time lterm;
 513                  clear_term false (mk_lterm what);
 514                  clear_term false (mk_lterm with_what)
 515               ]
 516            in
 517            subst_tac ~direction ~lterm ~where:None ~continuation
 518         | Some (C.Name name, _) :: tl when j < index && j <> k ->
 519            debug_print (lazy ("\nsubst programmata: cosa: " ^ string_of_int index ^ ", dove: " ^ string_of_int j));
 520            subst_tac ~direction ~lterm ~where:(Some name)
 521                      ~continuation:(traverse_context false (succ j) tl)
 522         | _ :: tl -> traverse_context first_time (succ j) tl
 523      in
 524      traverse_context first_time 1 context
 525   in
 526   let tac = match termty with
 527     | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]
 528       when LibraryObjects.is_eq_URI equri ->
 529           begin match t1,t2 with
 530 (* injection part *)
 531             | C.MutConstruct _,
 532               C.MutConstruct _
 533               when t1 = t2 -> clear_term first_time lterm
 534             | C.Appl (C.MutConstruct _ as mc1 :: applist1),
 535               C.Appl (C.MutConstruct _ as mc2 :: applist2)
 536               when mc1 = mc2 ->
 537                 let rec traverse_list first_time i l1 l2 =
 538                    match l1, l2 with
 539                       | [], [] -> clear_term first_time lterm
 540                       | hd1 :: tl1, hd2 :: tl2 ->
 541                         if are_convertible hd1 hd2 metasenv context then
 542                            traverse_list first_time (succ i) tl1 tl2
 543                         else
 544                            injection_tac ~i ~lterm ~continuation:
 545                               (traverse_list false (succ i) tl1 tl2)
 546                       | _ -> assert false
 547                       (* i 2 termini hanno in testa lo stesso costruttore,
 548                        * ma applicato a un numero diverso di termini *)
 549                 in
 550                   traverse_list first_time 1 applist1 applist2
 551 (* discriminate part *)
 552             | C.MutConstruct (_,_,consno1,ens1),
 553               C.MutConstruct (_,_,consno2,ens2)
 554             | C.MutConstruct (_,_,consno1,ens1),
 555               C.Appl ((C.MutConstruct (_,_,consno2,ens2))::_)
 556             | C.Appl ((C.MutConstruct (_,_,consno1,ens1))::_),
 557               C.MutConstruct (_,_,consno2,ens2)
 558             | C.Appl ((C.MutConstruct (_,_,consno1,ens1))::_),
 559               C.Appl ((C.MutConstruct (_,_,consno2,ens2))::_)
 560               when (consno1 <> consno2) || (ens1 <> ens2) ->
 561                 discriminate_tac ~term
 562 (* subst part *)
 563             | C.Rel _, C.Rel _ when t1 = t2 ->
 564                 T.seq ~tactics:[
 565                    clear_term first_time lterm;
 566                    clear_term false (mk_lterm t1)
 567                 ]
 568             | C.Rel i1, C.Rel i2 when i1 < i2 ->
 569                mk_subst_chain `LeftToRight i1 t2 t1
 570             | C.Rel i1, C.Rel i2 when i1 > i2 ->
 571                mk_subst_chain `RightToLeft i2 t1 t2
 572             | C.Rel i1, _ when DTI.does_not_occur i1 t2 ->
 573                mk_subst_chain `LeftToRight i1 t2 t1
 574             | _, C.Rel i2 when DTI.does_not_occur i2 t1 ->
 575                mk_subst_chain `RightToLeft i2 t1 t2
 576 (* else part *)
 577             | _ when first_time && simplified -> raise exn_nothingtodo
 578             | _ when simplified (* && not first time *) -> T.id_tac
 579             | _ (* when not simplified *) ->
 580                T.then_ ~start:(simpl_in_term context term)
 581                        ~continuation:(destruct ~simplified:true ~first_time term)
 582            end
 583      | _ when first_time && simplified -> raise exn_nothingtodo
 584      | _ when simplified (* && not first time *) -> T.id_tac
 585      | _ (* when not simplified *) ->
 586         T.then_ ~start:(simpl_in_term context term)
 587                 ~continuation:(destruct ~simplified:true ~first_time term)
 588   in
 589     PET.apply_tactic tac status
 590  in
 591    PET.mk_tactic destruct
 592
 593 let lazy_destruct_tac ~first_time ~lterm =
 594    let lazy_destruct status =
 595       let (proof, goal) = status in
 596       let _,metasenv,_subst,_,_, _ = proof in
 597       let _,context,_ = CicUtil.lookup_meta goal metasenv in
 598       let term, _, _ = lterm context metasenv CU.empty_ugraph in
 599       let tactic =
 600          if exists context term then destruct ~first_time term else T.id_tac
 601       in
 602       PET.apply_tactic tactic status
 603    in
 604    PET.mk_tactic lazy_destruct
 605
 606 (* destruct performs either injection or discriminate *)
 607 (* equivalent to Coq's "analyze equality"             *)
 608 let destruct_tac = function
 609    | Some term -> destruct ~first_time:true term
 610    | None      ->
 611       let destruct_all status =
 612          let (proof, goal) = status in
 613          let _,metasenv,_subst,_,_, _ = proof in
 614          let _,context,_ = CicUtil.lookup_meta goal metasenv in
 615          let mk_lterm term c m ug =
 616             let distance = List.length c - List.length context in
 617             S.lift distance term, m, ug
 618          in
 619          let rec mk_tactics first_time i tacs = function
 620             | []           -> List.rev tacs
 621             | Some _ :: tl ->
 622                let lterm = mk_lterm (C.Rel i) in
 623                let tacs = lazy_destruct_tac ~first_time ~lterm :: tacs in
 624                mk_tactics false (succ i) tacs tl
 625            | _ :: tl       -> mk_tactics first_time (succ i) tacs tl
 626          in
 627          let tactics = mk_tactics false 1 [] context in
 628          PET.apply_tactic (T.seq ~tactics) status
 629       in
 630       PET.mk_tactic destruct_all