]> matita.cs.unibo.it Git - helm.git/blob - helm/ocaml/tactics/proofEngineReduction.ml
removed ancient lablgtk, lablgtk_gtkmathview
[helm.git] / helm / ocaml / tactics / proofEngineReduction.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 (******************************************************************************)
27 (*                                                                            *)
28 (*                               PROJECT HELM                                 *)
29 (*                                                                            *)
30 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
31 (*                                 12/04/2002                                 *)
32 (*                                                                            *)
33 (*                                                                            *)
34 (******************************************************************************)
35
36
37 (* The code of this module is derived from the code of CicReduction *)
38
39 exception Impossible of int;;
40 exception ReferenceToConstant;;
41 exception ReferenceToVariable;;
42 exception ReferenceToCurrentProof;;
43 exception ReferenceToInductiveDefinition;;
44 exception WrongUriToInductiveDefinition;;
45 exception WrongUriToConstant;;
46 exception RelToHiddenHypothesis;;
47
48 let alpha_equivalence =
49  let module C = Cic in
50   let rec aux t t' =
51    if t = t' then true
52    else
53     match t,t' with
54        C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2) ->
55         UriManager.eq uri1 uri2 &&
56          aux_exp_named_subst exp_named_subst1 exp_named_subst2
57      | C.Cast (te,ty), C.Cast (te',ty') ->
58         aux te te' && aux ty ty'
59      | C.Prod (_,s,t), C.Prod (_,s',t') ->
60         aux s s' && aux t t'
61      | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
62         aux s s' && aux t t'
63      | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
64         aux s s' && aux t t'
65      | C.Appl l, C.Appl l' ->
66         (try
67           List.fold_left2
68            (fun b t1 t2 -> b && aux t1 t2) true l l'
69          with
70           Invalid_argument _ -> false)
71      | C.Const (uri,exp_named_subst1), C.Const (uri',exp_named_subst2) ->
72         UriManager.eq uri uri' &&
73          aux_exp_named_subst exp_named_subst1 exp_named_subst2
74      | C.MutInd (uri,i,exp_named_subst1), C.MutInd (uri',i',exp_named_subst2) ->
75         UriManager.eq uri uri' && i = i' &&
76          aux_exp_named_subst exp_named_subst1 exp_named_subst2
77      | C.MutConstruct (uri,i,j,exp_named_subst1),
78        C.MutConstruct (uri',i',j',exp_named_subst2) ->
79         UriManager.eq uri uri' && i = i' && j = j' &&
80          aux_exp_named_subst exp_named_subst1 exp_named_subst2
81      | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
82         UriManager.eq sp sp' && i = i' &&
83          aux outt outt' && aux t t' &&
84           (try
85             List.fold_left2
86              (fun b t1 t2 -> b && aux t1 t2) true pl pl'
87            with
88             Invalid_argument _ -> false)
89      | C.Fix (i,fl), C.Fix (i',fl') ->
90         i = i' &&
91         (try
92           List.fold_left2
93            (fun b (_,i,ty,bo) (_,i',ty',bo') ->
94              b && i = i' && aux ty ty' && aux bo bo'
95            ) true fl fl'
96          with
97           Invalid_argument _ -> false)
98      | C.CoFix (i,fl), C.CoFix (i',fl') ->
99         i = i' &&
100         (try
101           List.fold_left2
102            (fun b (_,ty,bo) (_,ty',bo') ->
103              b && aux ty ty' && aux bo bo'
104            ) true fl fl'
105          with
106           Invalid_argument _ -> false)
107      | _,_ -> false (* we already know that t != t' *)
108   and aux_exp_named_subst exp_named_subst1 exp_named_subst2 =
109    try
110      List.fold_left2
111       (fun b (uri1,t1) (uri2,t2) ->
112         b && UriManager.eq uri1 uri2 && aux t1 t2
113       ) true exp_named_subst1 exp_named_subst2
114     with
115      Invalid_argument _ -> false
116   in
117    aux
118 ;;
119
120 exception WhatAndWithWhatDoNotHaveTheSameLength;;
121
122 (* "textual" replacement of several subterms with other ones *)
123 let replace ~equality ~what ~with_what ~where =
124  let module C = Cic in
125   let find_image t =
126    let rec find_image_aux =
127     function
128        [],[] -> raise Not_found
129      | what::tl1,with_what::tl2 ->
130         if equality t what then with_what else find_image_aux (tl1,tl2)
131      | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
132    in
133     find_image_aux (what,with_what)
134   in
135   let rec aux t =
136    try
137     find_image t
138    with Not_found ->
139     match t with
140        C.Rel _ -> t
141      | C.Var (uri,exp_named_subst) ->
142         C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
143      | C.Meta _ -> t
144      | C.Sort _ -> t
145      | C.Implicit as t -> t
146      | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
147      | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
148      | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
149      | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
150      | C.Appl l ->
151         (* Invariant enforced: no application of an application *)
152         (match List.map aux l with
153             (C.Appl l')::tl -> C.Appl (l'@tl)
154           | l' -> C.Appl l')
155      | C.Const (uri,exp_named_subst) ->
156         C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
157      | C.MutInd (uri,i,exp_named_subst) ->
158         C.MutInd
159          (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
160      | C.MutConstruct (uri,i,j,exp_named_subst) ->
161         C.MutConstruct
162          (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
163      | C.MutCase (sp,i,outt,t,pl) ->
164         C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
165      | C.Fix (i,fl) ->
166         let substitutedfl =
167          List.map
168           (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
169            fl
170         in
171          C.Fix (i, substitutedfl)
172      | C.CoFix (i,fl) ->
173         let substitutedfl =
174          List.map
175           (fun (name,ty,bo) -> (name, aux ty, aux bo))
176            fl
177         in
178          C.CoFix (i, substitutedfl)
179    in
180     aux where
181 ;;
182
183 (* replaces in a term a term with another one. *)
184 (* Lifting are performed as usual.             *)
185 let replace_lifting ~equality ~what ~with_what ~where =
186  let module C = Cic in
187  let module S = CicSubstitution in
188   let find_image what t =
189    let rec find_image_aux =
190     function
191        [],[] -> raise Not_found
192      | what::tl1,with_what::tl2 ->
193         if equality t what then with_what else find_image_aux (tl1,tl2)
194      | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
195    in
196     find_image_aux (what,with_what)
197   in
198   let rec substaux k what t =
199    try
200     S.lift (k-1) (find_image what t)
201    with Not_found ->
202     match t with
203       C.Rel n as t -> t
204     | C.Var (uri,exp_named_subst) ->
205        let exp_named_subst' =
206         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
207        in
208         C.Var (uri,exp_named_subst')
209     | C.Meta (i, l) as t -> 
210        let l' =
211         List.map
212          (function
213              None -> None
214            | Some t -> Some (substaux k what t)
215          ) l
216        in
217         C.Meta(i,l')
218     | C.Sort _ as t -> t
219     | C.Implicit as t -> t
220     | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
221     | C.Prod (n,s,t) ->
222        C.Prod
223         (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
224     | C.Lambda (n,s,t) ->
225        C.Lambda
226         (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
227     | C.LetIn (n,s,t) ->
228        C.LetIn
229         (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
230     | C.Appl (he::tl) ->
231        (* Invariant: no Appl applied to another Appl *)
232        let tl' = List.map (substaux k what) tl in
233         begin
234          match substaux k what he with
235             C.Appl l -> C.Appl (l@tl')
236           | _ as he' -> C.Appl (he'::tl')
237         end
238     | C.Appl _ -> assert false
239     | C.Const (uri,exp_named_subst) ->
240        let exp_named_subst' =
241         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
242        in
243        C.Const (uri,exp_named_subst')
244     | C.MutInd (uri,i,exp_named_subst) ->
245        let exp_named_subst' =
246         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
247        in
248         C.MutInd (uri,i,exp_named_subst')
249     | C.MutConstruct (uri,i,j,exp_named_subst) ->
250        let exp_named_subst' =
251         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
252        in
253         C.MutConstruct (uri,i,j,exp_named_subst')
254     | C.MutCase (sp,i,outt,t,pl) ->
255        C.MutCase (sp,i,substaux k what outt, substaux k what t,
256         List.map (substaux k what) pl)
257     | C.Fix (i,fl) ->
258        let len = List.length fl in
259        let substitutedfl =
260         List.map
261          (fun (name,i,ty,bo) ->
262            (name, i, substaux k what ty,
263              substaux (k+len) (List.map (S.lift len) what) bo)
264          ) fl
265        in
266         C.Fix (i, substitutedfl)
267     | C.CoFix (i,fl) ->
268        let len = List.length fl in
269        let substitutedfl =
270         List.map
271          (fun (name,ty,bo) ->
272            (name, substaux k what ty,
273              substaux (k+len) (List.map (S.lift len) what) bo)
274          ) fl
275        in
276         C.CoFix (i, substitutedfl)
277  in
278   substaux 1 what where
279 ;;
280
281 (* replaces in a term a list of terms with other ones. *)
282 (* Lifting are performed as usual.                     *)
283 let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
284  let module C = Cic in
285  let module S = CicSubstitution in
286   let find_image t =
287    let rec find_image_aux =
288     function
289        [],[] -> raise Not_found
290      | what::tl1,with_what::tl2 ->
291         if equality t what then with_what else find_image_aux (tl1,tl2)
292      | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
293    in
294     find_image_aux (what,with_what)
295   in
296   let rec substaux k t =
297    try
298     S.lift (k-1) (find_image t)
299    with Not_found ->
300     match t with
301        C.Rel n as t ->
302         if n < k then C.Rel n else C.Rel (n + nnn)
303      | C.Var (uri,exp_named_subst) ->
304         let exp_named_subst' =
305          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
306         in
307          C.Var (uri,exp_named_subst')
308      | C.Meta (i, l) as t -> 
309         let l' =
310          List.map
311           (function
312               None -> None
313             | Some t -> Some (substaux k t)
314           ) l
315         in
316          C.Meta(i,l')
317      | C.Sort _ as t -> t
318      | C.Implicit as t -> t
319      | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
320      | C.Prod (n,s,t) ->
321         C.Prod (n, substaux k s, substaux (k + 1) t)
322      | C.Lambda (n,s,t) ->
323         C.Lambda (n, substaux k s, substaux (k + 1) t)
324      | C.LetIn (n,s,t) ->
325         C.LetIn (n, substaux k s, substaux (k + 1) t)
326      | C.Appl (he::tl) ->
327         (* Invariant: no Appl applied to another Appl *)
328         let tl' = List.map (substaux k) tl in
329          begin
330           match substaux k he with
331              C.Appl l -> C.Appl (l@tl')
332            | _ as he' -> C.Appl (he'::tl')
333          end
334      | C.Appl _ -> assert false
335      | C.Const (uri,exp_named_subst) ->
336         let exp_named_subst' =
337          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
338         in
339         C.Const (uri,exp_named_subst')
340      | C.MutInd (uri,i,exp_named_subst) ->
341         let exp_named_subst' =
342          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
343         in
344          C.MutInd (uri,i,exp_named_subst')
345      | C.MutConstruct (uri,i,j,exp_named_subst) ->
346         let exp_named_subst' =
347          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
348         in
349          C.MutConstruct (uri,i,j,exp_named_subst')
350      | C.MutCase (sp,i,outt,t,pl) ->
351         C.MutCase (sp,i,substaux k outt, substaux k t,
352          List.map (substaux k) pl)
353      | C.Fix (i,fl) ->
354         let len = List.length fl in
355         let substitutedfl =
356          List.map
357           (fun (name,i,ty,bo) ->
358             (name, i, substaux k ty, substaux (k+len) bo))
359            fl
360         in
361          C.Fix (i, substitutedfl)
362      | C.CoFix (i,fl) ->
363         let len = List.length fl in
364         let substitutedfl =
365          List.map
366           (fun (name,ty,bo) ->
367             (name, substaux k ty, substaux (k+len) bo))
368            fl
369         in
370          C.CoFix (i, substitutedfl)
371  in
372   substaux 1 where
373 ;;
374
375 (* Takes a well-typed term and fully reduces it. *)
376 (*CSC: It does not perform reduction in a Case *)
377 let reduce context =
378  let rec reduceaux context l =
379   let module C = Cic in
380   let module S = CicSubstitution in
381    function
382       C.Rel n as t ->
383        (match List.nth context (n-1) with
384            Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
385          | Some (_,C.Def (bo,_)) -> reduceaux context l (S.lift n bo)
386          | None -> raise RelToHiddenHypothesis
387        )
388     | C.Var (uri,exp_named_subst) ->
389        let exp_named_subst' =
390         reduceaux_exp_named_subst context l exp_named_subst
391        in
392        (match CicEnvironment.get_obj uri with
393            C.Constant _ -> raise ReferenceToConstant
394          | C.CurrentProof _ -> raise ReferenceToCurrentProof
395          | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
396          | C.Variable (_,None,_,_) ->
397             let t' = C.Var (uri,exp_named_subst') in
398              if l = [] then t' else C.Appl (t'::l)
399          | C.Variable (_,Some body,_,_) ->
400             (reduceaux context l
401               (CicSubstitution.subst_vars exp_named_subst' body))
402        )
403     | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
404     | C.Sort _ as t -> t (* l should be empty *)
405     | C.Implicit as t -> t
406     | C.Cast (te,ty) ->
407        C.Cast (reduceaux context l te, reduceaux context l ty)
408     | C.Prod (name,s,t) ->
409        assert (l = []) ;
410        C.Prod (name,
411         reduceaux context [] s,
412         reduceaux ((Some (name,C.Decl s))::context) [] t)
413     | C.Lambda (name,s,t) ->
414        (match l with
415            [] ->
416             C.Lambda (name,
417              reduceaux context [] s,
418              reduceaux ((Some (name,C.Decl s))::context) [] t)
419          | he::tl -> reduceaux context tl (S.subst he t)
420            (* when name is Anonimous the substitution should be superfluous *)
421        )
422     | C.LetIn (n,s,t) ->
423        reduceaux context l (S.subst (reduceaux context [] s) t)
424     | C.Appl (he::tl) ->
425        let tl' = List.map (reduceaux context []) tl in
426         reduceaux context (tl'@l) he
427     | C.Appl [] -> raise (Impossible 1)
428     | C.Const (uri,exp_named_subst) ->
429        let exp_named_subst' =
430         reduceaux_exp_named_subst context l exp_named_subst
431        in
432         (match CicEnvironment.get_obj uri with
433             C.Constant (_,Some body,_,_) ->
434              (reduceaux context l
435                (CicSubstitution.subst_vars exp_named_subst' body))
436           | C.Constant (_,None,_,_) ->
437              let t' = C.Const (uri,exp_named_subst') in
438               if l = [] then t' else C.Appl (t'::l)
439           | C.Variable _ -> raise ReferenceToVariable
440           | C.CurrentProof (_,_,body,_,_) ->
441              (reduceaux context l
442                (CicSubstitution.subst_vars exp_named_subst' body))
443           | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
444         )
445     | C.MutInd (uri,i,exp_named_subst) ->
446        let exp_named_subst' =
447         reduceaux_exp_named_subst context l exp_named_subst
448        in
449         let t' = C.MutInd (uri,i,exp_named_subst') in
450          if l = [] then t' else C.Appl (t'::l)
451     | C.MutConstruct (uri,i,j,exp_named_subst) as t ->
452        let exp_named_subst' =
453         reduceaux_exp_named_subst context l exp_named_subst
454        in
455         let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
456          if l = [] then t' else C.Appl (t'::l)
457     | C.MutCase (mutind,i,outtype,term,pl) ->
458        let decofix =
459         function
460            C.CoFix (i,fl) as t ->
461             let tys =
462              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
463             in
464              let (_,_,body) = List.nth fl i in
465               let body' =
466                let counter = ref (List.length fl) in
467                 List.fold_right
468                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
469                  fl
470                  body
471               in
472                reduceaux context [] body'
473          | C.Appl (C.CoFix (i,fl) :: tl) ->
474             let tys =
475              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
476             in
477              let (_,_,body) = List.nth fl i in
478               let body' =
479                let counter = ref (List.length fl) in
480                 List.fold_right
481                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
482                  fl
483                  body
484               in
485                let tl' = List.map (reduceaux context []) tl in
486                 reduceaux context tl' body'
487          | t -> t
488        in
489         (match decofix (reduceaux context [] term) with
490             C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
491           | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
492              let (arity, r) =
493               match CicEnvironment.get_obj mutind with
494                  C.InductiveDefinition (tl,_,r) ->
495                    let (_,_,arity,_) = List.nth tl i in
496                     (arity,r)
497                | _ -> raise WrongUriToInductiveDefinition
498              in
499               let ts =
500                let rec eat_first =
501                 function
502                    (0,l) -> l
503                  | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
504                  | _ -> raise (Impossible 5)
505                in
506                 eat_first (r,tl)
507               in
508                reduceaux context (ts@l) (List.nth pl (j-1))
509          | C.Cast _ | C.Implicit ->
510             raise (Impossible 2) (* we don't trust our whd ;-) *)
511          | _ ->
512            let outtype' = reduceaux context [] outtype in
513            let term' = reduceaux context [] term in
514            let pl' = List.map (reduceaux context []) pl in
515             let res =
516              C.MutCase (mutind,i,outtype',term',pl')
517             in
518              if l = [] then res else C.Appl (res::l)
519        )
520     | C.Fix (i,fl) ->
521        let tys =
522         List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
523        in
524         let t' () =
525          let fl' =
526           List.map
527            (function (n,recindex,ty,bo) ->
528              (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
529            ) fl
530          in
531           C.Fix (i, fl')
532         in
533          let (_,recindex,_,body) = List.nth fl i in
534           let recparam =
535            try
536             Some (List.nth l recindex)
537            with
538             _ -> None
539           in
540            (match recparam with
541                Some recparam ->
542                 (match reduceaux context [] recparam with
543                     C.MutConstruct _
544                   | C.Appl ((C.MutConstruct _)::_) ->
545                      let body' =
546                       let counter = ref (List.length fl) in
547                        List.fold_right
548                         (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
549                         fl
550                         body
551                      in
552                       (* Possible optimization: substituting whd recparam in l*)
553                       reduceaux context l body'
554                   | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
555                 )
556              | None -> if l = [] then t' () else C.Appl ((t' ())::l)
557            )
558     | C.CoFix (i,fl) ->
559        let tys =
560         List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
561        in
562         let t' =
563          let fl' =
564           List.map
565            (function (n,ty,bo) ->
566              (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
567            ) fl
568          in
569           C.CoFix (i, fl')
570         in
571          if l = [] then t' else C.Appl (t'::l)
572  and reduceaux_exp_named_subst context l =
573   List.map (function uri,t -> uri,reduceaux context [] t)
574  in
575   reduceaux context []
576 ;;
577
578 exception WrongShape;;
579 exception AlreadySimplified;;
580
581 (* Takes a well-typed term and                                               *)
582 (*  1) Performs beta-iota-zeta reduction until delta reduction is needed     *)
583 (*  2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted  *)
584 (*     w.r.t. zero or more variables and if the Fix can be reduced, than it  *)
585 (*     is reduced, the delta-reduction is succesfull and the whole algorithm *)
586 (*     is applied again to the new redex; Step 3) is applied to the result   *)
587 (*     of the recursive simplification. Otherwise, if the Fix can not be     *)
588 (*     reduced, than the delta-reductions fails and the delta-redex is       *)
589 (*     not reduced. Otherwise, if the delta-residual is not the              *)
590 (*     lambda-abstraction of a Fix, then it is reduced and the result is     *)
591 (*     directly returned, without performing step 3).                        *) 
592 (*  3) Folds the application of the constant to the arguments that did not   *)
593 (*     change in every iteration, i.e. to the actual arguments for the       *)
594 (*     lambda-abstractions that precede the Fix.                             *)
595 (*CSC: It does not perform simplification in a Case *)
596 let simpl context =
597  (* reduceaux is equal to the reduceaux locally defined inside *)
598  (* reduce, but for the const case.                            *) 
599  (**** Step 1 ****)
600  let rec reduceaux context l =
601   let module C = Cic in
602   let module S = CicSubstitution in
603    function
604       C.Rel n as t ->
605        (match List.nth context (n-1) with
606            Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
607          | Some (_,C.Def (bo,_)) ->
608             try_delta_expansion l t (S.lift n bo)
609          | None -> raise RelToHiddenHypothesis
610        )
611     | C.Var (uri,exp_named_subst) ->
612        let exp_named_subst' =
613         reduceaux_exp_named_subst context l exp_named_subst
614        in
615         (match CicEnvironment.get_obj uri with
616             C.Constant _ -> raise ReferenceToConstant
617           | C.CurrentProof _ -> raise ReferenceToCurrentProof
618           | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
619           | C.Variable (_,None,_,_) ->
620             let t' = C.Var (uri,exp_named_subst') in
621              if l = [] then t' else C.Appl (t'::l)
622           | C.Variable (_,Some body,_,_) ->
623              reduceaux context l
624               (CicSubstitution.subst_vars exp_named_subst' body)
625         )
626     | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
627     | C.Sort _ as t -> t (* l should be empty *)
628     | C.Implicit as t -> t
629     | C.Cast (te,ty) ->
630        C.Cast (reduceaux context l te, reduceaux context l ty)
631     | C.Prod (name,s,t) ->
632        assert (l = []) ;
633        C.Prod (name,
634         reduceaux context [] s,
635         reduceaux ((Some (name,C.Decl s))::context) [] t)
636     | C.Lambda (name,s,t) ->
637        (match l with
638            [] ->
639             C.Lambda (name,
640              reduceaux context [] s,
641              reduceaux ((Some (name,C.Decl s))::context) [] t)
642          | he::tl -> reduceaux context tl (S.subst he t)
643            (* when name is Anonimous the substitution should be superfluous *)
644        )
645     | C.LetIn (n,s,t) ->
646        reduceaux context l (S.subst (reduceaux context [] s) t)
647     | C.Appl (he::tl) ->
648        let tl' = List.map (reduceaux context []) tl in
649         reduceaux context (tl'@l) he
650     | C.Appl [] -> raise (Impossible 1)
651     | C.Const (uri,exp_named_subst) ->
652        let exp_named_subst' =
653         reduceaux_exp_named_subst context l exp_named_subst
654        in
655         (match CicEnvironment.get_obj uri with
656            C.Constant (_,Some body,_,_) ->
657             try_delta_expansion l
658              (C.Const (uri,exp_named_subst'))
659              (CicSubstitution.subst_vars exp_named_subst' body)
660          | C.Constant (_,None,_,_) ->
661             let t' = C.Const (uri,exp_named_subst') in
662              if l = [] then t' else C.Appl (t'::l)
663          | C.Variable _ -> raise ReferenceToVariable
664          | C.CurrentProof (_,_,body,_,_) -> reduceaux context l body
665          | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
666        )
667     | C.MutInd (uri,i,exp_named_subst) ->
668        let exp_named_subst' =
669         reduceaux_exp_named_subst context l exp_named_subst
670        in
671         let t' = C.MutInd (uri,i,exp_named_subst') in
672          if l = [] then t' else C.Appl (t'::l)
673     | C.MutConstruct (uri,i,j,exp_named_subst) ->
674        let exp_named_subst' =
675         reduceaux_exp_named_subst context l exp_named_subst
676        in
677         let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
678          if l = [] then t' else C.Appl (t'::l)
679     | C.MutCase (mutind,i,outtype,term,pl) ->
680        let decofix =
681         function
682            C.CoFix (i,fl) as t ->
683             let tys =
684              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl            in
685              let (_,_,body) = List.nth fl i in
686               let body' =
687                let counter = ref (List.length fl) in
688                 List.fold_right
689                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
690                  fl
691                  body
692               in
693                reduceaux context [] body'
694          | C.Appl (C.CoFix (i,fl) :: tl) ->
695             let tys =
696              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl            in
697              let (_,_,body) = List.nth fl i in
698               let body' =
699                let counter = ref (List.length fl) in
700                 List.fold_right
701                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
702                  fl
703                  body
704               in
705                let tl' = List.map (reduceaux context []) tl in
706                 reduceaux context tl body'
707          | t -> t
708        in
709         (match decofix (reduceaux context [] term) with
710             C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
711           | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
712              let (arity, r) =
713               match CicEnvironment.get_obj mutind with
714                  C.InductiveDefinition (tl,ingredients,r) ->
715                    let (_,_,arity,_) = List.nth tl i in
716                     (arity,r)
717                | _ -> raise WrongUriToInductiveDefinition
718              in
719               let ts =
720                let rec eat_first =
721                 function
722                    (0,l) -> l
723                  | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
724                  | _ -> raise (Impossible 5)
725                in
726                 eat_first (r,tl)
727               in
728                reduceaux context (ts@l) (List.nth pl (j-1))
729          | C.Cast _ | C.Implicit ->
730             raise (Impossible 2) (* we don't trust our whd ;-) *)
731          | _ ->
732            let outtype' = reduceaux context [] outtype in
733            let term' = reduceaux context [] term in
734            let pl' = List.map (reduceaux context []) pl in
735             let res =
736              C.MutCase (mutind,i,outtype',term',pl')
737             in
738              if l = [] then res else C.Appl (res::l)
739        )
740     | C.Fix (i,fl) ->
741        let tys =
742         List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
743        in
744         let t' () =
745          let fl' =
746           List.map
747            (function (n,recindex,ty,bo) ->
748              (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
749            ) fl
750          in
751           C.Fix (i, fl')
752         in
753          let (_,recindex,_,body) = List.nth fl i in
754           let recparam =
755            try
756             Some (List.nth l recindex)
757            with
758             _ -> None
759           in
760            (match recparam with
761                Some recparam ->
762                 (match reduceaux context [] recparam with
763                     C.MutConstruct _
764                   | C.Appl ((C.MutConstruct _)::_) ->
765                      let body' =
766                       let counter = ref (List.length fl) in
767                        List.fold_right
768                         (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
769                         fl
770                         body
771                      in
772                       (* Possible optimization: substituting whd recparam in l*)
773                       reduceaux context l body'
774                   | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
775                 )
776              | None -> if l = [] then t' () else C.Appl ((t' ())::l)
777            )
778     | C.CoFix (i,fl) ->
779        let tys =
780         List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
781        in
782         let t' =
783          let fl' =
784           List.map
785            (function (n,ty,bo) ->
786              (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
787            ) fl
788          in
789          C.CoFix (i, fl')
790        in
791          if l = [] then t' else C.Appl (t'::l)
792  and reduceaux_exp_named_subst context l =
793   List.map (function uri,t -> uri,reduceaux context [] t)
794  (**** Step 2 ****)
795  and try_delta_expansion l term body =
796   let module C = Cic in
797   let module S = CicSubstitution in
798    try
799     let res,constant_args =
800      let rec aux rev_constant_args l =
801       function
802          C.Lambda (name,s,t) as t' ->
803           begin
804            match l with
805               [] -> raise WrongShape
806             | he::tl ->
807                (* when name is Anonimous the substitution should *)
808                (* be superfluous                                 *)
809                aux (he::rev_constant_args) tl (S.subst he t)
810           end
811        | C.LetIn (_,s,t) ->
812           aux rev_constant_args l (S.subst s t)
813        | C.Fix (i,fl) as t ->
814           let tys =
815            List.map (function (name,_,ty,_) ->
816             Some (C.Name name, C.Decl ty)) fl
817           in
818            let (_,recindex,_,body) = List.nth fl i in
819             let recparam =
820              try
821               List.nth l recindex
822              with
823               _ -> raise AlreadySimplified
824             in
825              (match CicReduction.whd context recparam with
826                  C.MutConstruct _
827                | C.Appl ((C.MutConstruct _)::_) ->
828                   let body' =
829                    let counter = ref (List.length fl) in
830                     List.fold_right
831                      (function _ ->
832                        decr counter ; S.subst (C.Fix (!counter,fl))
833                      ) fl body
834                   in
835                    (* Possible optimization: substituting whd *)
836                    (* recparam in l                           *)
837                    reduceaux context l body',
838                     List.rev rev_constant_args
839                | _ -> raise AlreadySimplified
840              )
841        | _ -> raise WrongShape
842      in
843       aux [] l body
844     in
845      (**** Step 3 ****)
846      let term_to_fold, delta_expanded_term_to_fold =
847       match constant_args with
848          [] -> term,body
849        | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
850      in
851       let simplified_term_to_fold =
852        reduceaux context [] delta_expanded_term_to_fold
853       in
854        replace (=) [simplified_term_to_fold] [term_to_fold] res
855    with
856       WrongShape ->
857        (* The constant does not unfold to a Fix lambda-abstracted  *)
858        (* w.r.t. zero or more variables. We just perform reduction.*)
859        reduceaux context l body
860     | AlreadySimplified ->
861        (* If we performed delta-reduction, we would find a Fix   *)
862        (* not applied to a constructor. So, we refuse to perform *)
863        (* delta-reduction.                                       *)
864        if l = [] then term else C.Appl (term::l)
865  in
866   reduceaux context []
867 ;;