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