]> matita.cs.unibo.it Git - helm.git/blob - helm/software/components/tactics/destructTactic.ml
we were generating a name for the main fix twice
[helm.git] / helm / software / 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.oblivion_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.oblivion_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.oblivion_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 recur_on_child_tac ~before ~after =
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 tactic = T.then_ ~start:before ~continuation:(after lterm) in
263       PET.apply_tactic tactic status  
264    in
265    PET.mk_tactic recur_on_child
266    
267 let injection_tac ~lterm ~i ~continuation ~recur =
268  let give_name seed = function
269    | C.Name _ as name -> name
270    | C.Anonymous -> C.Name (incr seed; "y" ^ string_of_int !seed)
271  in
272  let rec mk_rels = function | 0 -> [] | n -> C.Rel n :: (mk_rels (n - 1)) in
273  let injection_tac status =
274   let (proof, goal) = status in
275   (* precondizione: t1 e t2 hanno in testa lo stesso costruttore ma 
276    * differiscono (o potrebbero differire?) nell'i-esimo parametro 
277    * del costruttore *)
278   let _,metasenv,_subst,_,_, _ = proof in
279   let _,context,_ = CicUtil.lookup_meta goal metasenv in
280   let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in
281   let termty,_ =
282     CTC.type_of_aux' metasenv context term CU.oblivion_ugraph
283   in
284   debug_print (lazy ("\ninjection su : " ^ pp context termty)); 
285   match termty with (* an equality *)
286    | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2]
287     when LibraryObjects.is_eq_URI equri -> 
288       let turi,typeno,ens,params =
289         match tty with (* some inductive type *)
290         | C.MutInd (turi,typeno,ens) -> turi,typeno,ens,[]
291         | C.Appl (C.MutInd (turi,typeno,ens)::params) -> turi,typeno,ens,params
292         | _ -> raise exn_noneqind
293       in
294       let t1',t2',consno = (* sono i due sottotermini che differiscono *)
295         match t1,t2 with
296         | C.Appl ((C.MutConstruct (uri1,typeno1,consno1,ens1))::applist1),
297           C.Appl ((C.MutConstruct (uri2,typeno2,consno2,ens2))::applist2)
298           when (uri1 = uri2) && (typeno1 = typeno2) && 
299                (consno1 = consno2) && (ens1 = ens2) -> 
300                (* controllo ridondante *)
301             List.nth applist1 (pred i),List.nth applist2 (pred i),consno2
302         | _ -> assert false
303       in
304       let tty',_ = CTC.type_of_aux' metasenv context t1' CU.oblivion_ugraph in
305       let patterns,outtype =
306         match fst (CicEnvironment.get_obj CU.oblivion_ugraph turi) with
307         | C.InductiveDefinition (ind_type_list,_,paramsno,_)->
308            let left_params, right_params = HExtlib.split_nth paramsno params in
309            let _,_,_,constructor_list = List.nth ind_type_list typeno in
310            let i_constr_id,_ = List.nth constructor_list (consno - 1) in
311            let patterns =
312              let seed = ref 0 in
313              List.map
314                (function (id,cty) ->
315                  let reduced_cty = CR.whd context cty in
316                  let rec aux k = function
317                    | C.Prod (_,_,tgt) when k <= paramsno -> 
318                        let left = List.nth left_params (k-1) in
319                        aux (k+1) (S.subst left tgt)
320                    | C.Prod (binder,source,target) when k > paramsno ->
321                       let binder' = give_name seed binder in
322                       C.Lambda (binder',source,(aux (k+1) target))
323                    | _ ->
324                      let nr_param_constr = k - paramsno - 1 in
325                      if id = i_constr_id then C.Rel (k - i)
326                      else S.lift nr_param_constr t1' 
327                      (* + 1 per liftare anche il lambda aggiunto
328                       * esternamente al case *)
329                  in S.lift 1 (aux 1 reduced_cty))
330                constructor_list 
331            in
332            (* this code should be taken from cases_tac *)
333            let outtype =
334              let seed = ref 0 in
335              let rec to_lambdas te head =
336                match CR.whd context te with
337                | C.Prod (binder,so,ta) ->
338                    let binder' = give_name seed binder in
339                    C.Lambda (binder',so,to_lambdas ta head)
340                | _ -> head 
341              in
342              let rec skip_prods params te =
343                match params, CR.whd context te with
344                | [], _ -> te
345                | left::tl, C.Prod (_,_,ta) -> 
346                    skip_prods tl (S.subst left ta)
347                | _, _ -> assert false
348              in
349              let abstracted_tty =
350                let tty =
351                  List.fold_left (fun x y -> S.subst y x) tty left_params
352                in
353                (* non lift, ma subst coi left! *)
354                match S.lift 1 tty with
355                | C.MutInd _ as tty' -> tty'
356                | C.Appl l ->
357                    let keep,abstract = HExtlib.split_nth (paramsno +1) l in
358                    let keep = List.map (S.lift paramsno) keep in
359                    C.Appl (keep@mk_rels (List.length abstract))
360                | _ -> assert false
361              in
362              match ind_type_list with
363              | [] -> assert false
364              | (_,_,ty,_)::_ ->
365                (* this is in general wrong, do as in cases_tac *)
366                to_lambdas (skip_prods left_params ty)
367                  (C.Lambda 
368                    (C.Name "cased", abstracted_tty,
369                      (* here we should capture right parameters *)
370                      (* 1 for his Lambda, one for the Lambda outside the match
371                       * and then one for each to_lambda *)
372                      S.lift (2+List.length right_params) tty'))
373           in
374             patterns,outtype
375         | _ -> raise exn_discrnonind
376       in
377       let cutted = C.Appl [C.MutInd (equri,0,[]) ; tty' ; t1' ; t2'] in
378       let changed = 
379         C.Appl [ C.Lambda (C.Name "x", tty, 
380                   C.MutCase (turi,typeno,outtype,C.Rel 1,patterns)) ; t1]
381       in
382       (* check if cutted and changed are well typed and if t1' ~ changed *)
383       let go_on =
384         try
385           let _,g = CTC.type_of_aux' metasenv context  cutted
386             CU.oblivion_ugraph
387           in
388           let _,g = CTC.type_of_aux' metasenv context changed g in
389           fst (CR.are_convertible ~metasenv context  t1' changed g)
390         with
391         | CTC.TypeCheckerFailure _ -> false
392       in
393       if not go_on then begin
394         HLog.warn "destruct: injection failed";
395         PET.apply_tactic continuation status
396       end else
397         let fill_cut_tac term = 
398            let fill_cut status =
399                debug_print (lazy "riempio il cut"); 
400                let (proof, goal) = status in
401                let _,metasenv,_subst,_,_, _ = proof in
402                let _,context,gty = CicUtil.lookup_meta goal metasenv in
403                let gty = Unshare.unshare gty in
404                let new_t1' = match gty with 
405                   | (C.Appl (C.MutInd (_,_,_)::_::t::_)) -> t
406                   | _ -> raise exn_injwronggoal
407                in
408                debug_print (lazy ("metto: " ^ pp context changed));
409                debug_print (lazy ("al posto di: " ^ pp context new_t1'));
410                debug_print (lazy ("nel goal: " ^ pp context gty));
411                debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context));
412                debug_print (lazy ("e poi rewrite con: "^pp context term));
413                let tac = T.seq ~tactics:[
414                   RT.change_tac
415                      ~pattern:(None, [], Some (PEH.pattern_of ~term:gty [new_t1']))
416                      (fun _ m u -> changed,m,u);
417                   ET.rewrite_simpl_tac
418                      ~direction:`LeftToRight
419                      ~pattern:(PET.conclusion_pattern None)
420                      term [];
421                   ET.reflexivity_tac   
422                ] in
423                PET.apply_tactic tac status
424            in
425            PET.mk_tactic fill_cut
426         in
427         debug_print (lazy ("CUT: " ^ pp context cutted));  
428         let tactic = 
429            T.thens ~start: (P.cut_tac cutted)
430                    ~continuations:[
431                       recur_on_child_tac continuation recur;
432                       fill_cut_tac term
433                    ]
434         in
435         PET.apply_tactic tactic status
436    | _ -> raise exn_noneq
437  in
438   PET.mk_tactic injection_tac
439
440 let subst_tac ~lterm ~direction ~where ~continuation ~recur =
441    let subst_tac status =
442       let (proof, goal) = status in
443       let _,metasenv,_subst,_,_, _ = proof in
444       let _,context,_ = CicUtil.lookup_meta goal metasenv in
445       let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in
446       debug_print (lazy ("\nsubst " ^ (match direction with `LeftToRight -> "->" | `RightToLeft -> "<-") ^ " di: " ^ pp context term));
447       let tactic = match where with
448          | None      -> 
449             debug_print (lazy ("nella conclusione"));
450             let pattern = PET.conclusion_pattern None in
451             let tactic = ET.rewrite_tac ~direction ~pattern term [] in
452             T.then_ ~start:(T.try_tactic ~tactic) ~continuation
453          | Some name ->
454             debug_print (lazy ("nella premessa: " ^ name));
455             let pattern = None, [name, PET.hole], None in
456             let start = ET.rewrite_tac ~direction ~pattern term [] in
457             let ok_tactic = recur_on_child_tac continuation recur in
458             T.if_ ~start ~continuation:ok_tactic ~fail:continuation         
459       in 
460       PET.apply_tactic tactic status
461    in
462    PET.mk_tactic subst_tac
463
464 let rec destruct ~first_time lterm =
465  let are_convertible hd1 hd2 metasenv context = 
466    fst (CR.are_convertible ~metasenv context hd1 hd2 CU.oblivion_ugraph)
467  in
468  let recur = destruct ~first_time:false 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.oblivion_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.oblivion_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 ~recur
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) ~recur 
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 ~recur ~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 xterms =
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 xterms with 
576          | Some terms -> 
577             let map term = destruct ~first_time:false (mk_lterm term) in
578             List.map map terms
579          | None       ->
580             let rec mk_tactics first_time i tacs = function
581                | []           -> List.rev tacs
582                | Some _ :: tl -> 
583                   let lterm = mk_lterm (C.Rel i) in
584                   let tacs = destruct ~first_time lterm :: tacs in
585                   mk_tactics false (succ i) tacs tl 
586                | _ :: tl      -> mk_tactics first_time (succ i) tacs tl
587             in
588             mk_tactics false 1 [] context
589       in
590       PET.apply_tactic (T.seq ~tactics) status
591    in
592    PET.mk_tactic destruct