1 (* Copyright (C) 2002, HELM Team.
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.
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.
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.
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,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
26 (******************************************************************************)
30 (* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
34 (******************************************************************************)
38 (* The code of this module is derived from the code of CicReduction *)
40 exception Impossible of int;;
41 exception ReferenceToConstant;;
42 exception ReferenceToVariable;;
43 exception ReferenceToCurrentProof;;
44 exception ReferenceToInductiveDefinition;;
45 exception WrongUriToInductiveDefinition;;
46 exception WrongUriToConstant;;
47 exception RelToHiddenHypothesis;;
49 let alpha_equivalence =
55 C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2) ->
56 UriManager.eq uri1 uri2 &&
57 aux_exp_named_subst exp_named_subst1 exp_named_subst2
58 | C.Cast (te,ty), C.Cast (te',ty') ->
59 aux te te' && aux ty ty'
60 | C.Prod (_,s,t), C.Prod (_,s',t') ->
62 | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
64 | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
66 | C.Appl l, C.Appl l' ->
69 (fun b t1 t2 -> b && aux t1 t2) true l l'
71 Invalid_argument _ -> false)
72 | C.Const (uri,exp_named_subst1), C.Const (uri',exp_named_subst2) ->
73 UriManager.eq uri uri' &&
74 aux_exp_named_subst exp_named_subst1 exp_named_subst2
75 | C.MutInd (uri,i,exp_named_subst1), C.MutInd (uri',i',exp_named_subst2) ->
76 UriManager.eq uri uri' && i = i' &&
77 aux_exp_named_subst exp_named_subst1 exp_named_subst2
78 | C.MutConstruct (uri,i,j,exp_named_subst1),
79 C.MutConstruct (uri',i',j',exp_named_subst2) ->
80 UriManager.eq uri uri' && i = i' && j = j' &&
81 aux_exp_named_subst exp_named_subst1 exp_named_subst2
82 | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
83 UriManager.eq sp sp' && i = i' &&
84 aux outt outt' && aux t t' &&
87 (fun b t1 t2 -> b && aux t1 t2) true pl pl'
89 Invalid_argument _ -> false)
90 | C.Fix (i,fl), C.Fix (i',fl') ->
94 (fun b (_,i,ty,bo) (_,i',ty',bo') ->
95 b && i = i' && aux ty ty' && aux bo bo'
98 Invalid_argument _ -> false)
99 | C.CoFix (i,fl), C.CoFix (i',fl') ->
103 (fun b (_,ty,bo) (_,ty',bo') ->
104 b && aux ty ty' && aux bo bo'
107 Invalid_argument _ -> false)
108 | _,_ -> false (* we already know that t != t' *)
109 and aux_exp_named_subst exp_named_subst1 exp_named_subst2 =
112 (fun b (uri1,t1) (uri2,t2) ->
113 b && UriManager.eq uri1 uri2 && aux t1 t2
114 ) true exp_named_subst1 exp_named_subst2
116 Invalid_argument _ -> false
121 exception WhatAndWithWhatDoNotHaveTheSameLength;;
123 (* "textual" replacement of several subterms with other ones *)
124 let replace ~equality ~what ~with_what ~where =
125 let module C = Cic in
127 let rec find_image_aux =
129 [],[] -> raise Not_found
130 | what::tl1,with_what::tl2 ->
131 if equality what t then with_what else find_image_aux (tl1,tl2)
132 | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
134 find_image_aux (what,with_what)
142 | C.Var (uri,exp_named_subst) ->
143 C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
146 | C.Implicit _ as t -> t
147 | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
148 | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
149 | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
150 | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
152 (* Invariant enforced: no application of an application *)
153 (match List.map aux l with
154 (C.Appl l')::tl -> C.Appl (l'@tl)
156 | C.Const (uri,exp_named_subst) ->
157 C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
158 | C.MutInd (uri,i,exp_named_subst) ->
160 (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
161 | C.MutConstruct (uri,i,j,exp_named_subst) ->
163 (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
164 | C.MutCase (sp,i,outt,t,pl) ->
165 C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
169 (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
172 C.Fix (i, substitutedfl)
176 (fun (name,ty,bo) -> (name, aux ty, aux bo))
179 C.CoFix (i, substitutedfl)
184 (* replaces in a term a term with another one. *)
185 (* Lifting are performed as usual. *)
186 let replace_lifting ~equality ~what ~with_what ~where =
187 let module C = Cic in
188 let module S = CicSubstitution in
189 let find_image what t =
190 let rec find_image_aux =
192 [],[] -> raise Not_found
193 | what::tl1,with_what::tl2 ->
194 if equality what t then with_what else find_image_aux (tl1,tl2)
195 | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
197 find_image_aux (what,with_what)
199 let rec substaux k what t =
201 S.lift (k-1) (find_image what t)
205 | C.Var (uri,exp_named_subst) ->
206 let exp_named_subst' =
207 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
209 C.Var (uri,exp_named_subst')
215 | Some t -> Some (substaux k what t)
220 | C.Implicit _ as t -> t
221 | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
224 (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
225 | C.Lambda (n,s,t) ->
227 (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
230 (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
232 (* Invariant: no Appl applied to another Appl *)
233 let tl' = List.map (substaux k what) tl in
235 match substaux k what he with
236 C.Appl l -> C.Appl (l@tl')
237 | _ as he' -> C.Appl (he'::tl')
239 | C.Appl _ -> assert false
240 | C.Const (uri,exp_named_subst) ->
241 let exp_named_subst' =
242 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
244 C.Const (uri,exp_named_subst')
245 | C.MutInd (uri,i,exp_named_subst) ->
246 let exp_named_subst' =
247 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
249 C.MutInd (uri,i,exp_named_subst')
250 | C.MutConstruct (uri,i,j,exp_named_subst) ->
251 let exp_named_subst' =
252 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
254 C.MutConstruct (uri,i,j,exp_named_subst')
255 | C.MutCase (sp,i,outt,t,pl) ->
256 C.MutCase (sp,i,substaux k what outt, substaux k what t,
257 List.map (substaux k what) pl)
259 let len = List.length fl in
262 (fun (name,i,ty,bo) ->
263 (name, i, substaux k what ty,
264 substaux (k+len) (List.map (S.lift len) what) bo)
267 C.Fix (i, substitutedfl)
269 let len = List.length fl in
273 (name, substaux k what ty,
274 substaux (k+len) (List.map (S.lift len) what) bo)
277 C.CoFix (i, substitutedfl)
279 substaux 1 what where
282 (* replaces in a term a list of terms with other ones. *)
283 (* Lifting are performed as usual. *)
284 let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
285 let module C = Cic in
286 let module S = CicSubstitution in
288 let rec find_image_aux =
290 [],[] -> raise Not_found
291 | what::tl1,with_what::tl2 ->
292 if equality what t then with_what else find_image_aux (tl1,tl2)
293 | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
295 find_image_aux (what,with_what)
297 let rec substaux k t =
299 S.lift (k-1) (find_image t)
303 if n < k then C.Rel n else C.Rel (n + nnn)
304 | C.Var (uri,exp_named_subst) ->
305 let exp_named_subst' =
306 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
308 C.Var (uri,exp_named_subst')
314 | Some t -> Some (substaux k t)
319 | C.Implicit _ as t -> t
320 | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
322 C.Prod (n, substaux k s, substaux (k + 1) t)
323 | C.Lambda (n,s,t) ->
324 C.Lambda (n, substaux k s, substaux (k + 1) t)
326 C.LetIn (n, substaux k s, substaux (k + 1) t)
328 (* Invariant: no Appl applied to another Appl *)
329 let tl' = List.map (substaux k) tl in
331 match substaux k he with
332 C.Appl l -> C.Appl (l@tl')
333 | _ as he' -> C.Appl (he'::tl')
335 | C.Appl _ -> assert false
336 | C.Const (uri,exp_named_subst) ->
337 let exp_named_subst' =
338 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
340 C.Const (uri,exp_named_subst')
341 | C.MutInd (uri,i,exp_named_subst) ->
342 let exp_named_subst' =
343 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
345 C.MutInd (uri,i,exp_named_subst')
346 | C.MutConstruct (uri,i,j,exp_named_subst) ->
347 let exp_named_subst' =
348 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
350 C.MutConstruct (uri,i,j,exp_named_subst')
351 | C.MutCase (sp,i,outt,t,pl) ->
352 C.MutCase (sp,i,substaux k outt, substaux k t,
353 List.map (substaux k) pl)
355 let len = List.length fl in
358 (fun (name,i,ty,bo) ->
359 (name, i, substaux k ty, substaux (k+len) bo))
362 C.Fix (i, substitutedfl)
364 let len = List.length fl in
368 (name, substaux k ty, substaux (k+len) bo))
371 C.CoFix (i, substitutedfl)
376 (* Takes a well-typed term and fully reduces it. *)
377 (*CSC: It does not perform reduction in a Case *)
379 let rec reduceaux context l =
380 let module C = Cic in
381 let module S = CicSubstitution in
384 (match List.nth context (n-1) with
385 Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
386 | Some (_,C.Def (bo,_)) -> reduceaux context l (S.lift n bo)
387 | None -> raise RelToHiddenHypothesis
389 | C.Var (uri,exp_named_subst) ->
390 let exp_named_subst' =
391 reduceaux_exp_named_subst context l exp_named_subst
393 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
395 C.Constant _ -> raise ReferenceToConstant
396 | C.CurrentProof _ -> raise ReferenceToCurrentProof
397 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
398 | C.Variable (_,None,_,_,_) ->
399 let t' = C.Var (uri,exp_named_subst') in
400 if l = [] then t' else C.Appl (t'::l)
401 | C.Variable (_,Some body,_,_,_) ->
403 (CicSubstitution.subst_vars exp_named_subst' body))
405 | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
406 | C.Sort _ as t -> t (* l should be empty *)
407 | C.Implicit _ as t -> t
409 C.Cast (reduceaux context l te, reduceaux context l ty)
410 | C.Prod (name,s,t) ->
413 reduceaux context [] s,
414 reduceaux ((Some (name,C.Decl s))::context) [] t)
415 | C.Lambda (name,s,t) ->
419 reduceaux context [] s,
420 reduceaux ((Some (name,C.Decl s))::context) [] t)
421 | he::tl -> reduceaux context tl (S.subst he t)
422 (* when name is Anonimous the substitution should be superfluous *)
425 reduceaux context l (S.subst (reduceaux context [] s) t)
427 let tl' = List.map (reduceaux context []) tl in
428 reduceaux context (tl'@l) he
429 | C.Appl [] -> raise (Impossible 1)
430 | C.Const (uri,exp_named_subst) ->
431 let exp_named_subst' =
432 reduceaux_exp_named_subst context l exp_named_subst
434 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
436 C.Constant (_,Some body,_,_,_) ->
438 (CicSubstitution.subst_vars exp_named_subst' body))
439 | C.Constant (_,None,_,_,_) ->
440 let t' = C.Const (uri,exp_named_subst') in
441 if l = [] then t' else C.Appl (t'::l)
442 | C.Variable _ -> raise ReferenceToVariable
443 | C.CurrentProof (_,_,body,_,_,_) ->
445 (CicSubstitution.subst_vars exp_named_subst' body))
446 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
448 | C.MutInd (uri,i,exp_named_subst) ->
449 let exp_named_subst' =
450 reduceaux_exp_named_subst context l exp_named_subst
452 let t' = C.MutInd (uri,i,exp_named_subst') in
453 if l = [] then t' else C.Appl (t'::l)
454 | C.MutConstruct (uri,i,j,exp_named_subst) ->
455 let exp_named_subst' =
456 reduceaux_exp_named_subst context l exp_named_subst
458 let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
459 if l = [] then t' else C.Appl (t'::l)
460 | C.MutCase (mutind,i,outtype,term,pl) ->
464 let (_,_,body) = List.nth fl i in
466 let counter = ref (List.length fl) in
468 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
472 reduceaux context [] body'
473 | C.Appl (C.CoFix (i,fl) :: tl) ->
474 let (_,_,body) = List.nth fl i in
476 let counter = ref (List.length fl) in
478 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
482 let tl' = List.map (reduceaux context []) tl in
483 reduceaux context tl' body'
486 (match decofix (reduceaux context [] term) with
487 C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
488 | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
490 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
492 C.InductiveDefinition (tl,_,r,_) ->
493 let (_,_,arity,_) = List.nth tl i in
495 | _ -> raise WrongUriToInductiveDefinition
501 | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
502 | _ -> raise (Impossible 5)
506 reduceaux context (ts@l) (List.nth pl (j-1))
507 | C.Cast _ | C.Implicit _ ->
508 raise (Impossible 2) (* we don't trust our whd ;-) *)
510 let outtype' = reduceaux context [] outtype in
511 let term' = reduceaux context [] term in
512 let pl' = List.map (reduceaux context []) pl in
514 C.MutCase (mutind,i,outtype',term',pl')
516 if l = [] then res else C.Appl (res::l)
520 List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
525 (function (n,recindex,ty,bo) ->
526 (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
531 let (_,recindex,_,body) = List.nth fl i in
534 Some (List.nth l recindex)
540 (match reduceaux context [] recparam with
542 | C.Appl ((C.MutConstruct _)::_) ->
544 let counter = ref (List.length fl) in
546 (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
550 (* Possible optimization: substituting whd recparam in l*)
551 reduceaux context l body'
552 | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
554 | None -> if l = [] then t' () else C.Appl ((t' ())::l)
558 List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
563 (function (n,ty,bo) ->
564 (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
569 if l = [] then t' else C.Appl (t'::l)
570 and reduceaux_exp_named_subst context l =
571 List.map (function uri,t -> uri,reduceaux context [] t)
576 exception WrongShape;;
577 exception AlreadySimplified;;
579 (* Takes a well-typed term and *)
580 (* 1) Performs beta-iota-zeta reduction until delta reduction is needed *)
581 (* 2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted *)
582 (* w.r.t. zero or more variables and if the Fix can be reductaed, than it*)
583 (* is reduced, the delta-reduction is succesfull and the whole algorithm *)
584 (* is applied again to the new redex; Step 3.1) is applied to the result *)
585 (* of the recursive simplification. Otherwise, if the Fix can not be *)
586 (* reduced, than the delta-reductions fails and the delta-redex is *)
587 (* not reduced. Otherwise, if the delta-residual is not the *)
588 (* lambda-abstraction of a Fix, then it performs step 3.2). *)
589 (* 3.1) Folds the application of the constant to the arguments that did not *)
590 (* change in every iteration, i.e. to the actual arguments for the *)
591 (* lambda-abstractions that precede the Fix. *)
592 (* 3.2) Computes the head beta-zeta normal form of the term. Then it tries *)
593 (* reductions. If the reduction cannot be performed, it returns the *)
594 (* original term (not the head beta-zeta normal form of the definiendum) *)
595 (*CSC: It does not perform simplification in a Case *)
598 (* reduceaux is equal to the reduceaux locally defined inside *)
599 (* reduce, but for the const case. *)
601 let rec reduceaux context l =
602 let module C = Cic in
603 let module S = CicSubstitution in
607 match List.nth context (n-1) with
608 Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
609 | Some (_,C.Def (bo,_)) ->
610 try_delta_expansion context l t (S.lift n bo)
611 | None -> raise RelToHiddenHypothesis
613 Failure _ -> assert false)
614 | C.Var (uri,exp_named_subst) ->
615 let exp_named_subst' =
616 reduceaux_exp_named_subst context l exp_named_subst
618 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
620 C.Constant _ -> raise ReferenceToConstant
621 | C.CurrentProof _ -> raise ReferenceToCurrentProof
622 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
623 | C.Variable (_,None,_,_,_) ->
624 let t' = C.Var (uri,exp_named_subst') in
625 if l = [] then t' else C.Appl (t'::l)
626 | C.Variable (_,Some body,_,_,_) ->
628 (CicSubstitution.subst_vars exp_named_subst' body)
630 | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
631 | C.Sort _ as t -> t (* l should be empty *)
632 | C.Implicit _ as t -> t
634 C.Cast (reduceaux context l te, reduceaux context l ty)
635 | C.Prod (name,s,t) ->
638 reduceaux context [] s,
639 reduceaux ((Some (name,C.Decl s))::context) [] t)
640 | C.Lambda (name,s,t) ->
644 reduceaux context [] s,
645 reduceaux ((Some (name,C.Decl s))::context) [] t)
646 | he::tl -> reduceaux context tl (S.subst he t)
647 (* when name is Anonimous the substitution should be superfluous *)
650 reduceaux context l (S.subst (reduceaux context [] s) t)
652 let tl' = List.map (reduceaux context []) tl in
653 reduceaux context (tl'@l) he
654 | C.Appl [] -> raise (Impossible 1)
655 | C.Const (uri,exp_named_subst) ->
656 let exp_named_subst' =
657 reduceaux_exp_named_subst context l exp_named_subst
659 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
661 C.Constant (_,Some body,_,_,_) ->
662 try_delta_expansion context l
663 (C.Const (uri,exp_named_subst'))
664 (CicSubstitution.subst_vars exp_named_subst' body)
665 | C.Constant (_,None,_,_,_) ->
666 let t' = C.Const (uri,exp_named_subst') in
667 if l = [] then t' else C.Appl (t'::l)
668 | C.Variable _ -> raise ReferenceToVariable
669 | C.CurrentProof (_,_,body,_,_,_) -> reduceaux context l body
670 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
672 | C.MutInd (uri,i,exp_named_subst) ->
673 let exp_named_subst' =
674 reduceaux_exp_named_subst context l exp_named_subst
676 let t' = C.MutInd (uri,i,exp_named_subst') in
677 if l = [] then t' else C.Appl (t'::l)
678 | C.MutConstruct (uri,i,j,exp_named_subst) ->
679 let exp_named_subst' =
680 reduceaux_exp_named_subst context l exp_named_subst
682 let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
683 if l = [] then t' else C.Appl (t'::l)
684 | C.MutCase (mutind,i,outtype,term,pl) ->
688 let (_,_,body) = List.nth fl i in
690 let counter = ref (List.length fl) in
692 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
696 reduceaux context [] body'
697 | C.Appl (C.CoFix (i,fl) :: tl) ->
699 List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl in
700 let (_,_,body) = List.nth fl i in
702 let counter = ref (List.length fl) in
704 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
708 let tl' = List.map (reduceaux context []) tl in
709 reduceaux context tl' body'
712 (match decofix (CicReduction.whd context term) with
713 C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
714 | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
716 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
718 C.InductiveDefinition (tl,ingredients,r,_) ->
719 let (_,_,arity,_) = List.nth tl i in
721 | _ -> raise WrongUriToInductiveDefinition
727 | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
728 | _ -> raise (Impossible 5)
732 reduceaux context (ts@l) (List.nth pl (j-1))
733 | C.Cast _ | C.Implicit _ ->
734 raise (Impossible 2) (* we don't trust our whd ;-) *)
736 let outtype' = reduceaux context [] outtype in
737 let term' = reduceaux context [] term in
738 let pl' = List.map (reduceaux context []) pl in
740 C.MutCase (mutind,i,outtype',term',pl')
742 if l = [] then res else C.Appl (res::l)
746 List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
751 (function (n,recindex,ty,bo) ->
752 (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
757 let (_,recindex,_,body) = List.nth fl i in
760 Some (List.nth l recindex)
766 (match reduceaux context [] recparam with
768 | C.Appl ((C.MutConstruct _)::_) ->
770 let counter = ref (List.length fl) in
772 (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
776 (* Possible optimization: substituting whd recparam in l*)
777 reduceaux context l body'
778 | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
780 | None -> if l = [] then t' () else C.Appl ((t' ())::l)
784 List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
789 (function (n,ty,bo) ->
790 (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
795 if l = [] then t' else C.Appl (t'::l)
796 and reduceaux_exp_named_subst context l =
797 List.map (function uri,t -> uri,reduceaux context [] t)
799 and try_delta_expansion context l term body =
800 let module C = Cic in
801 let module S = CicSubstitution in
803 let res,constant_args =
804 let rec aux rev_constant_args l =
806 C.Lambda (name,s,t) ->
809 [] -> raise WrongShape
811 (* when name is Anonimous the substitution should *)
813 aux (he::rev_constant_args) tl (S.subst he t)
816 aux rev_constant_args l (S.subst s t)
818 let (_,recindex,_,body) = List.nth fl i in
823 _ -> raise AlreadySimplified
825 (match CicReduction.whd context recparam with
827 | C.Appl ((C.MutConstruct _)::_) ->
829 let counter = ref (List.length fl) in
832 decr counter ; S.subst (C.Fix (!counter,fl))
835 (* Possible optimization: substituting whd *)
837 reduceaux context l body',
838 List.rev rev_constant_args
839 | _ -> raise AlreadySimplified
841 | _ -> raise WrongShape
846 let term_to_fold, delta_expanded_term_to_fold =
847 match constant_args with
849 | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
851 let simplified_term_to_fold =
852 reduceaux context [] delta_expanded_term_to_fold
854 replace (=) [simplified_term_to_fold] [term_to_fold] res
860 C.Lambda (name,s,t) ->
862 [] -> raise AlreadySimplified
864 (* when name is Anonimous the substitution should *)
866 aux tl (S.subst he t))
867 | C.LetIn (_,s,t) -> aux l (S.subst s t)
869 let simplified = reduceaux context l t in
870 if t = simplified then
871 raise AlreadySimplified
878 if l = [] then term else C.Appl (term::l))
879 | AlreadySimplified ->
880 (* If we performed delta-reduction, we would find a Fix *)
881 (* not applied to a constructor. So, we refuse to perform *)
882 (* delta-reduction. *)
883 if l = [] then term else C.Appl (term::l)
888 let unfold ?what context where =
889 let contextlen = List.length context in
890 let first_is_the_expandable_head_of_second context' t1 t2 =
892 Cic.Const (uri,_), Cic.Const (uri',_)
893 | Cic.Var (uri,_), Cic.Var (uri',_)
894 | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_)
895 | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri'
897 | Cic.Var _, _ -> false
898 | Cic.Rel n, Cic.Rel m
899 | Cic.Rel n, Cic.Appl (Cic.Rel m::_) ->
900 n + (List.length context' - contextlen) = m
901 | Cic.Rel _, _ -> false
904 (ProofEngineTypes.Fail
905 (lazy "The term to unfold is not a constant, a variable or a bound variable "))
908 if tl = [] then he else Cic.Appl (he::tl) in
909 let cannot_delta_expand t =
911 (ProofEngineTypes.Fail
912 (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in
913 let rec hd_delta_beta context tl =
917 match List.nth context (n-1) with
918 Some (_,Cic.Decl _) -> cannot_delta_expand t
919 | Some (_,Cic.Def (bo,_)) ->
920 CicReduction.head_beta_reduce
921 (appl (CicSubstitution.lift n bo) tl)
922 | None -> raise RelToHiddenHypothesis
924 Failure _ -> assert false)
925 | Cic.Const (uri,exp_named_subst) as t ->
926 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
928 Cic.Constant (_,Some body,_,_,_) ->
929 CicReduction.head_beta_reduce
930 (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
931 | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t
932 | Cic.Variable _ -> raise ReferenceToVariable
933 | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
934 | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
936 | Cic.Var (uri,exp_named_subst) as t ->
937 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
939 Cic.Constant _ -> raise ReferenceToConstant
940 | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
941 | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
942 | Cic.Variable (_,Some body,_,_,_) ->
943 CicReduction.head_beta_reduce
944 (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
945 | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t
947 | Cic.Appl [] -> assert false
948 | Cic.Appl (he::tl) -> hd_delta_beta context tl he
949 | t -> cannot_delta_expand t
951 let context_and_matched_term_list =
953 None -> [context, where]
956 ProofEngineHelpers.locate_in_term
957 ~equality:first_is_the_expandable_head_of_second
962 (ProofEngineTypes.Fail
963 (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where)))
969 (function (context,where) -> hd_delta_beta context [] where)
970 context_and_matched_term_list in
971 let whats = List.map snd context_and_matched_term_list in
972 replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where