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;;
50 module S = CicSubstitution
52 let alpha_equivalence =
57 C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2) ->
58 UriManager.eq uri1 uri2 &&
59 aux_exp_named_subst exp_named_subst1 exp_named_subst2
60 | C.Cast (te,ty), C.Cast (te',ty') ->
61 aux te te' && aux ty ty'
62 | C.Prod (_,s,t), C.Prod (_,s',t') ->
64 | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
66 | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
68 | C.Appl l, C.Appl l' ->
71 (fun b t1 t2 -> b && aux t1 t2) true l l'
73 Invalid_argument _ -> false)
74 | C.Const (uri,exp_named_subst1), C.Const (uri',exp_named_subst2) ->
75 UriManager.eq uri uri' &&
76 aux_exp_named_subst exp_named_subst1 exp_named_subst2
77 | C.MutInd (uri,i,exp_named_subst1), C.MutInd (uri',i',exp_named_subst2) ->
78 UriManager.eq uri uri' && i = i' &&
79 aux_exp_named_subst exp_named_subst1 exp_named_subst2
80 | C.MutConstruct (uri,i,j,exp_named_subst1),
81 C.MutConstruct (uri',i',j',exp_named_subst2) ->
82 UriManager.eq uri uri' && i = i' && j = j' &&
83 aux_exp_named_subst exp_named_subst1 exp_named_subst2
84 | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
85 UriManager.eq sp sp' && i = i' &&
86 aux outt outt' && aux t t' &&
89 (fun b t1 t2 -> b && aux t1 t2) true pl pl'
91 Invalid_argument _ -> false)
92 | C.Fix (i,fl), C.Fix (i',fl') ->
96 (fun b (_,i,ty,bo) (_,i',ty',bo') ->
97 b && i = i' && aux ty ty' && aux bo bo'
100 Invalid_argument _ -> false)
101 | C.CoFix (i,fl), C.CoFix (i',fl') ->
105 (fun b (_,ty,bo) (_,ty',bo') ->
106 b && aux ty ty' && aux bo bo'
109 Invalid_argument _ -> false)
110 | _,_ -> false (* we already know that t != t' *)
111 and aux_exp_named_subst exp_named_subst1 exp_named_subst2 =
114 (fun b (uri1,t1) (uri2,t2) ->
115 b && UriManager.eq uri1 uri2 && aux t1 t2
116 ) true exp_named_subst1 exp_named_subst2
118 Invalid_argument _ -> false
123 exception WhatAndWithWhatDoNotHaveTheSameLength;;
125 (* Replaces "textually" in "where" every term in "what" with the corresponding
126 term in "with_what". The terms in "what" ARE NOT lifted when binders are
127 crossed. The terms in "with_what" ARE NOT lifted when binders are crossed.
128 Every free variable in "where" IS NOT lifted by nnn.
130 let replace ~equality ~what ~with_what ~where =
132 let rec find_image_aux =
134 [],[] -> raise Not_found
135 | what::tl1,with_what::tl2 ->
136 if equality what t then with_what else find_image_aux (tl1,tl2)
137 | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
139 find_image_aux (what,with_what)
147 | C.Var (uri,exp_named_subst) ->
148 C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
151 | C.Implicit _ as t -> t
152 | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
153 | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
154 | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
155 | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
157 (* Invariant enforced: no application of an application *)
158 (match List.map aux l with
159 (C.Appl l')::tl -> C.Appl (l'@tl)
161 | C.Const (uri,exp_named_subst) ->
162 C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
163 | C.MutInd (uri,i,exp_named_subst) ->
165 (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
166 | C.MutConstruct (uri,i,j,exp_named_subst) ->
168 (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
169 | C.MutCase (sp,i,outt,t,pl) ->
170 C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
174 (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
177 C.Fix (i, substitutedfl)
181 (fun (name,ty,bo) -> (name, aux ty, aux bo))
184 C.CoFix (i, substitutedfl)
189 (* Replaces in "where" every term in "what" with the corresponding
190 term in "with_what". The terms in "what" ARE lifted when binders are
191 crossed. The terms in "with_what" ARE lifted when binders are crossed.
192 Every free variable in "where" IS NOT lifted by nnn.
193 Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the
194 inverse of subst up to the fact that free variables in "where" are NOT
196 let replace_lifting ~equality ~what ~with_what ~where =
197 let find_image what t =
198 let rec find_image_aux =
200 [],[] -> raise Not_found
201 | what::tl1,with_what::tl2 ->
202 if equality what t then with_what else find_image_aux (tl1,tl2)
203 | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
205 find_image_aux (what,with_what)
207 let rec substaux k what t =
209 S.lift (k-1) (find_image what t)
213 | C.Var (uri,exp_named_subst) ->
214 let exp_named_subst' =
215 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
217 C.Var (uri,exp_named_subst')
223 | Some t -> Some (substaux k what t)
228 | C.Implicit _ as t -> t
229 | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
232 (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
233 | C.Lambda (n,s,t) ->
235 (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
238 (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
240 (* Invariant: no Appl applied to another Appl *)
241 let tl' = List.map (substaux k what) tl in
243 match substaux k what he with
244 C.Appl l -> C.Appl (l@tl')
245 | _ as he' -> C.Appl (he'::tl')
247 | C.Appl _ -> assert false
248 | C.Const (uri,exp_named_subst) ->
249 let exp_named_subst' =
250 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
252 C.Const (uri,exp_named_subst')
253 | C.MutInd (uri,i,exp_named_subst) ->
254 let exp_named_subst' =
255 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
257 C.MutInd (uri,i,exp_named_subst')
258 | C.MutConstruct (uri,i,j,exp_named_subst) ->
259 let exp_named_subst' =
260 List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
262 C.MutConstruct (uri,i,j,exp_named_subst')
263 | C.MutCase (sp,i,outt,t,pl) ->
264 C.MutCase (sp,i,substaux k what outt, substaux k what t,
265 List.map (substaux k what) pl)
267 let len = List.length fl in
270 (fun (name,i,ty,bo) ->
271 (name, i, substaux k what ty,
272 substaux (k+len) (List.map (S.lift len) what) bo)
275 C.Fix (i, substitutedfl)
277 let len = List.length fl in
281 (name, substaux k what ty,
282 substaux (k+len) (List.map (S.lift len) what) bo)
285 C.CoFix (i, substitutedfl)
287 substaux 1 what where
290 (* Replaces in "where" every term in "what" with the corresponding
291 term in "with_what". The terms in "what" ARE NOT lifted when binders are
292 crossed. The terms in "with_what" ARE lifted when binders are crossed.
293 Every free variable in "where" IS lifted by nnn.
294 Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the
295 inverse of subst up to the fact that "what" terms are NOT lifted. *)
296 let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
298 let rec find_image_aux =
300 [],[] -> raise Not_found
301 | what::tl1,with_what::tl2 ->
302 if equality what t then with_what else find_image_aux (tl1,tl2)
303 | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
305 find_image_aux (what,with_what)
307 let rec substaux k t =
309 S.lift (k-1) (find_image t)
313 if n < k then C.Rel n else C.Rel (n + nnn)
314 | C.Var (uri,exp_named_subst) ->
315 let exp_named_subst' =
316 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
318 C.Var (uri,exp_named_subst')
324 | Some t -> Some (substaux k t)
329 | C.Implicit _ as t -> t
330 | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
332 C.Prod (n, substaux k s, substaux (k + 1) t)
333 | C.Lambda (n,s,t) ->
334 C.Lambda (n, substaux k s, substaux (k + 1) t)
336 C.LetIn (n, substaux k s, substaux (k + 1) t)
338 (* Invariant: no Appl applied to another Appl *)
339 let tl' = List.map (substaux k) tl in
341 match substaux k he with
342 C.Appl l -> C.Appl (l@tl')
343 | _ as he' -> C.Appl (he'::tl')
345 | C.Appl _ -> assert false
346 | C.Const (uri,exp_named_subst) ->
347 let exp_named_subst' =
348 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
350 C.Const (uri,exp_named_subst')
351 | C.MutInd (uri,i,exp_named_subst) ->
352 let exp_named_subst' =
353 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
355 C.MutInd (uri,i,exp_named_subst')
356 | C.MutConstruct (uri,i,j,exp_named_subst) ->
357 let exp_named_subst' =
358 List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
360 C.MutConstruct (uri,i,j,exp_named_subst')
361 | C.MutCase (sp,i,outt,t,pl) ->
362 C.MutCase (sp,i,substaux k outt, substaux k t,
363 List.map (substaux k) pl)
365 let len = List.length fl in
368 (fun (name,i,ty,bo) ->
369 (name, i, substaux k ty, substaux (k+len) bo))
372 C.Fix (i, substitutedfl)
374 let len = List.length fl in
378 (name, substaux k ty, substaux (k+len) bo))
381 C.CoFix (i, substitutedfl)
386 (* This is like "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]"
387 up to the fact that the index to start from can be specified *)
388 let replace_with_rel_1_from ~equality ~what =
389 let rec find_image t = function
391 | hd :: tl -> equality t hd || find_image t tl
393 let rec subst_term k t =
394 if find_image t what then C.Rel k else inspect_term k t
395 and inspect_term k = function
396 | C.Rel i -> if i < k then C.Rel i else C.Rel (succ i)
398 | C.Implicit _ as t -> t
399 | C.Var (uri, enss) ->
400 let enss = List.map (subst_ens k) enss in
402 | C.Const (uri ,enss) ->
403 let enss = List.map (subst_ens k) enss in
405 | C.MutInd (uri, tyno, enss) ->
406 let enss = List.map (subst_ens k) enss in
407 C.MutInd (uri, tyno, enss)
408 | C.MutConstruct (uri, tyno, consno, enss) ->
409 let enss = List.map (subst_ens k) enss in
410 C.MutConstruct (uri, tyno, consno, enss)
412 let mss = List.map (subst_ms k) mss in
414 | C.Cast (t, v) -> C.Cast (subst_term k t, subst_term k v)
416 let ts = List.map (subst_term k) ts in
418 | C.MutCase (uri, tyno, outty, t, cases) ->
419 let cases = List.map (subst_term k) cases in
420 C.MutCase (uri, tyno, subst_term k outty, subst_term k t, cases)
421 | C.Prod (n, v, t) ->
422 C.Prod (n, subst_term k v, subst_term (succ k) t)
423 | C.Lambda (n, v, t) ->
424 C.Lambda (n, subst_term k v, subst_term (succ k) t)
425 | C.LetIn (n, v, t) ->
426 C.LetIn (n, subst_term k v, subst_term (succ k) t)
427 | C.Fix (i, fixes) ->
428 let fixesno = List.length fixes in
429 let fixes = List.map (subst_fix fixesno k) fixes in
431 | C.CoFix (i, cofixes) ->
432 let cofixesno = List.length cofixes in
433 let cofixes = List.map (subst_cofix cofixesno k) cofixes in
435 and subst_ens k (uri, t) = uri, subst_term k t
436 and subst_ms k = function
438 | Some t -> Some (subst_term k t)
439 and subst_fix fixesno k (n, ind, ty, bo) =
440 n, ind, subst_term k ty, subst_term (k + fixesno) bo
441 and subst_cofix cofixesno k (n, ty, bo) =
442 n, subst_term k ty, subst_term (k + cofixesno) bo
449 (* Takes a well-typed term and fully reduces it. *)
450 (*CSC: It does not perform reduction in a Case *)
452 let rec reduceaux context l =
455 (match List.nth context (n-1) with
456 Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
457 | Some (_,C.Def (bo,_)) -> reduceaux context l (S.lift n bo)
458 | None -> raise RelToHiddenHypothesis
460 | C.Var (uri,exp_named_subst) ->
461 let exp_named_subst' =
462 reduceaux_exp_named_subst context l exp_named_subst
464 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
466 C.Constant _ -> raise ReferenceToConstant
467 | C.CurrentProof _ -> raise ReferenceToCurrentProof
468 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
469 | C.Variable (_,None,_,_,_) ->
470 let t' = C.Var (uri,exp_named_subst') in
471 if l = [] then t' else C.Appl (t'::l)
472 | C.Variable (_,Some body,_,_,_) ->
474 (CicSubstitution.subst_vars exp_named_subst' body))
476 | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
477 | C.Sort _ as t -> t (* l should be empty *)
478 | C.Implicit _ as t -> t
480 C.Cast (reduceaux context l te, reduceaux context l ty)
481 | C.Prod (name,s,t) ->
484 reduceaux context [] s,
485 reduceaux ((Some (name,C.Decl s))::context) [] t)
486 | C.Lambda (name,s,t) ->
490 reduceaux context [] s,
491 reduceaux ((Some (name,C.Decl s))::context) [] t)
492 | he::tl -> reduceaux context tl (S.subst he t)
493 (* when name is Anonimous the substitution should be superfluous *)
496 reduceaux context l (S.subst (reduceaux context [] s) t)
498 let tl' = List.map (reduceaux context []) tl in
499 reduceaux context (tl'@l) he
500 | C.Appl [] -> raise (Impossible 1)
501 | C.Const (uri,exp_named_subst) ->
502 let exp_named_subst' =
503 reduceaux_exp_named_subst context l exp_named_subst
505 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
507 C.Constant (_,Some body,_,_,_) ->
509 (CicSubstitution.subst_vars exp_named_subst' body))
510 | C.Constant (_,None,_,_,_) ->
511 let t' = C.Const (uri,exp_named_subst') in
512 if l = [] then t' else C.Appl (t'::l)
513 | C.Variable _ -> raise ReferenceToVariable
514 | C.CurrentProof (_,_,body,_,_,_) ->
516 (CicSubstitution.subst_vars exp_named_subst' body))
517 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
519 | C.MutInd (uri,i,exp_named_subst) ->
520 let exp_named_subst' =
521 reduceaux_exp_named_subst context l exp_named_subst
523 let t' = C.MutInd (uri,i,exp_named_subst') in
524 if l = [] then t' else C.Appl (t'::l)
525 | C.MutConstruct (uri,i,j,exp_named_subst) ->
526 let exp_named_subst' =
527 reduceaux_exp_named_subst context l exp_named_subst
529 let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
530 if l = [] then t' else C.Appl (t'::l)
531 | C.MutCase (mutind,i,outtype,term,pl) ->
535 let (_,_,body) = List.nth fl i in
537 let counter = ref (List.length fl) in
539 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
543 reduceaux context [] body'
544 | C.Appl (C.CoFix (i,fl) :: tl) ->
545 let (_,_,body) = List.nth fl i in
547 let counter = ref (List.length fl) in
549 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
553 let tl' = List.map (reduceaux context []) tl in
554 reduceaux context tl' body'
557 (match decofix (reduceaux context [] term) with
558 C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
559 | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
561 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
563 C.InductiveDefinition (tl,_,r,_) ->
564 let (_,_,arity,_) = List.nth tl i in
566 | _ -> raise WrongUriToInductiveDefinition
572 | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
573 | _ -> raise (Impossible 5)
577 reduceaux context (ts@l) (List.nth pl (j-1))
578 | C.Cast _ | C.Implicit _ ->
579 raise (Impossible 2) (* we don't trust our whd ;-) *)
581 let outtype' = reduceaux context [] outtype in
582 let term' = reduceaux context [] term in
583 let pl' = List.map (reduceaux context []) pl in
585 C.MutCase (mutind,i,outtype',term',pl')
587 if l = [] then res else C.Appl (res::l)
592 (fun (types,len) (n,_,ty,_) ->
593 (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
600 (function (n,recindex,ty,bo) ->
601 (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
606 let (_,recindex,_,body) = List.nth fl i in
609 Some (List.nth l recindex)
615 (match reduceaux context [] recparam with
617 | C.Appl ((C.MutConstruct _)::_) ->
619 let counter = ref (List.length fl) in
621 (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
625 (* Possible optimization: substituting whd recparam in l*)
626 reduceaux context l body'
627 | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
629 | None -> if l = [] then t' () else C.Appl ((t' ())::l)
634 (fun (types,len) (n,ty,_) ->
635 (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
642 (function (n,ty,bo) ->
643 (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
648 if l = [] then t' else C.Appl (t'::l)
649 and reduceaux_exp_named_subst context l =
650 List.map (function uri,t -> uri,reduceaux context [] t)
655 exception WrongShape;;
656 exception AlreadySimplified;;
658 (* Takes a well-typed term and *)
659 (* 1) Performs beta-iota-zeta reduction until delta reduction is needed *)
660 (* 2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted *)
661 (* w.r.t. zero or more variables and if the Fix can be reductaed, than it*)
662 (* is reduced, the delta-reduction is succesfull and the whole algorithm *)
663 (* is applied again to the new redex; Step 3.1) is applied to the result *)
664 (* of the recursive simplification. Otherwise, if the Fix can not be *)
665 (* reduced, than the delta-reductions fails and the delta-redex is *)
666 (* not reduced. Otherwise, if the delta-residual is not the *)
667 (* lambda-abstraction of a Fix, then it performs step 3.2). *)
668 (* 3.1) Folds the application of the constant to the arguments that did not *)
669 (* change in every iteration, i.e. to the actual arguments for the *)
670 (* lambda-abstractions that precede the Fix. *)
671 (* 3.2) Computes the head beta-zeta normal form of the term. Then it tries *)
672 (* reductions. If the reduction cannot be performed, it returns the *)
673 (* original term (not the head beta-zeta normal form of the definiendum) *)
674 (*CSC: It does not perform simplification in a Case *)
677 (* a simplified term is active if it can create a redex when used as an *)
678 (* actual parameter *)
683 | C.Appl (C.MutConstruct _::_)
685 | C.Cast (bo,_) -> is_active bo
686 | C.LetIn _ -> assert false
689 (* reduceaux is equal to the reduceaux locally defined inside *)
690 (* reduce, but for the const case. *)
692 let rec reduceaux context l =
695 (* we never perform delta expansion automatically *)
696 if l = [] then t else C.Appl (t::l)
697 | C.Var (uri,exp_named_subst) ->
698 let exp_named_subst' =
699 reduceaux_exp_named_subst context l exp_named_subst
701 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
703 C.Constant _ -> raise ReferenceToConstant
704 | C.CurrentProof _ -> raise ReferenceToCurrentProof
705 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
706 | C.Variable (_,None,_,_,_) ->
707 let t' = C.Var (uri,exp_named_subst') in
708 if l = [] then t' else C.Appl (t'::l)
709 | C.Variable (_,Some body,_,_,_) ->
711 (CicSubstitution.subst_vars exp_named_subst' body)
713 | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
714 | C.Sort _ as t -> t (* l should be empty *)
715 | C.Implicit _ as t -> t
717 C.Cast (reduceaux context l te, reduceaux context [] ty)
718 | C.Prod (name,s,t) ->
721 reduceaux context [] s,
722 reduceaux ((Some (name,C.Decl s))::context) [] t)
723 | C.Lambda (name,s,t) ->
727 reduceaux context [] s,
728 reduceaux ((Some (name,C.Decl s))::context) [] t)
729 | he::tl -> reduceaux context tl (S.subst he t)
730 (* when name is Anonimous the substitution should be superfluous *)
733 reduceaux context l (S.subst (reduceaux context [] s) t)
735 let tl' = List.map (reduceaux context []) tl in
736 reduceaux context (tl'@l) he
737 | C.Appl [] -> raise (Impossible 1)
738 | C.Const (uri,exp_named_subst) ->
739 let exp_named_subst' =
740 reduceaux_exp_named_subst context l exp_named_subst
742 (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
744 C.Constant (_,Some body,_,_,_) ->
745 if List.exists is_active l then
746 try_delta_expansion context l
747 (C.Const (uri,exp_named_subst'))
748 (CicSubstitution.subst_vars exp_named_subst' body)
750 let t' = C.Const (uri,exp_named_subst') in
751 if l = [] then t' else C.Appl (t'::l)
752 | C.Constant (_,None,_,_,_) ->
753 let t' = C.Const (uri,exp_named_subst') in
754 if l = [] then t' else C.Appl (t'::l)
755 | C.Variable _ -> raise ReferenceToVariable
756 | C.CurrentProof (_,_,body,_,_,_) -> reduceaux context l body
757 | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
759 | C.MutInd (uri,i,exp_named_subst) ->
760 let exp_named_subst' =
761 reduceaux_exp_named_subst context l exp_named_subst
763 let t' = C.MutInd (uri,i,exp_named_subst') in
764 if l = [] then t' else C.Appl (t'::l)
765 | C.MutConstruct (uri,i,j,exp_named_subst) ->
766 let exp_named_subst' =
767 reduceaux_exp_named_subst context l exp_named_subst
769 let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
770 if l = [] then t' else C.Appl (t'::l)
771 | C.MutCase (mutind,i,outtype,term,pl) ->
775 let (_,_,body) = List.nth fl i in
777 let counter = ref (List.length fl) in
779 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
783 reduceaux context [] body'
784 | C.Appl (C.CoFix (i,fl) :: tl) ->
785 let (_,_,body) = List.nth fl i in
787 let counter = ref (List.length fl) in
789 (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
793 let tl' = List.map (reduceaux context []) tl in
794 reduceaux context tl' body'
797 (match decofix (reduceaux context [] term) (*(CicReduction.whd context term)*) with
798 C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
799 | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
801 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
803 C.InductiveDefinition (tl,ingredients,r,_) ->
804 let (_,_,arity,_) = List.nth tl i in
806 | _ -> raise WrongUriToInductiveDefinition
812 | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
813 | _ -> raise (Impossible 5)
817 reduceaux context (ts@l) (List.nth pl (j-1))
818 | C.Cast _ | C.Implicit _ ->
819 raise (Impossible 2) (* we don't trust our whd ;-) *)
821 let outtype' = reduceaux context [] outtype in
822 let term' = reduceaux context [] term in
823 let pl' = List.map (reduceaux context []) pl in
825 C.MutCase (mutind,i,outtype',term',pl')
827 if l = [] then res else C.Appl (res::l)
832 (fun (types,len) (n,_,ty,_) ->
833 (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
840 (function (n,recindex,ty,bo) ->
841 (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
846 let (_,recindex,_,body) = List.nth fl i in
849 Some (List.nth l recindex)
855 (match reduceaux context [] recparam with
857 | C.Appl ((C.MutConstruct _)::_) ->
859 let counter = ref (List.length fl) in
861 (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
865 (* Possible optimization: substituting whd recparam in l*)
866 reduceaux context l body'
867 | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
869 | None -> if l = [] then t' () else C.Appl ((t' ())::l)
874 (fun (types,len) (n,ty,_) ->
875 (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
882 (function (n,ty,bo) ->
883 (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
888 if l = [] then t' else C.Appl (t'::l)
889 and reduceaux_exp_named_subst context l =
890 List.map (function uri,t -> uri,reduceaux context [] t)
892 and try_delta_expansion context l term body =
894 let res,constant_args =
895 let rec aux rev_constant_args l =
897 C.Lambda (name,s,t) ->
900 [] -> raise WrongShape
902 (* when name is Anonimous the substitution should *)
904 aux (he::rev_constant_args) tl (S.subst he t)
907 aux rev_constant_args l (S.subst s t)
909 let (_,recindex,_,body) = List.nth fl i in
914 _ -> raise AlreadySimplified
916 (match reduceaux context [] recparam (*CicReduction.whd context recparam*) with
918 | C.Appl ((C.MutConstruct _)::_) ->
920 let counter = ref (List.length fl) in
923 decr counter ; S.subst (C.Fix (!counter,fl))
926 (* Possible optimization: substituting whd *)
928 reduceaux context l body',
929 List.rev rev_constant_args
930 | _ -> raise AlreadySimplified
932 | _ -> raise WrongShape
937 let term_to_fold, delta_expanded_term_to_fold =
938 match constant_args with
940 | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
942 let simplified_term_to_fold =
943 reduceaux context [] delta_expanded_term_to_fold
945 replace_lifting (=) [simplified_term_to_fold] [term_to_fold] res
951 C.Lambda (name,s,t) ->
953 [] -> raise AlreadySimplified
955 (* when name is Anonimous the substitution should *)
957 aux tl (S.subst he t))
958 | C.LetIn (_,s,t) -> aux l (S.subst s t)
960 let simplified = reduceaux context l t in
961 let t' = if l = [] then t else C.Appl (t::l) in
962 if t' = simplified then
963 raise AlreadySimplified
970 if l = [] then term else C.Appl (term::l))
971 | AlreadySimplified ->
972 (* If we performed delta-reduction, we would find a Fix *)
973 (* not applied to a constructor. So, we refuse to perform *)
974 (* delta-reduction. *)
975 if l = [] then term else C.Appl (term::l)
980 let unfold ?what context where =
981 let contextlen = List.length context in
982 let first_is_the_expandable_head_of_second context' t1 t2 =
984 Cic.Const (uri,_), Cic.Const (uri',_)
985 | Cic.Var (uri,_), Cic.Var (uri',_)
986 | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_)
987 | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri'
989 | Cic.Var _, _ -> false
990 | Cic.Rel n, Cic.Rel m
991 | Cic.Rel n, Cic.Appl (Cic.Rel m::_) ->
992 n + (List.length context' - contextlen) = m
993 | Cic.Rel _, _ -> false
996 (ProofEngineTypes.Fail
997 (lazy "The term to unfold is not a constant, a variable or a bound variable "))
1000 if tl = [] then he else Cic.Appl (he::tl) in
1001 let cannot_delta_expand t =
1003 (ProofEngineTypes.Fail
1004 (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in
1005 let rec hd_delta_beta context tl =
1009 match List.nth context (n-1) with
1010 Some (_,Cic.Decl _) -> cannot_delta_expand t
1011 | Some (_,Cic.Def (bo,_)) ->
1012 CicReduction.head_beta_reduce
1013 (appl (CicSubstitution.lift n bo) tl)
1014 | None -> raise RelToHiddenHypothesis
1016 Failure _ -> assert false)
1017 | Cic.Const (uri,exp_named_subst) as t ->
1018 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
1020 Cic.Constant (_,Some body,_,_,_) ->
1021 CicReduction.head_beta_reduce
1022 (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
1023 | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t
1024 | Cic.Variable _ -> raise ReferenceToVariable
1025 | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
1026 | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
1028 | Cic.Var (uri,exp_named_subst) as t ->
1029 let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
1031 Cic.Constant _ -> raise ReferenceToConstant
1032 | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
1033 | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
1034 | Cic.Variable (_,Some body,_,_,_) ->
1035 CicReduction.head_beta_reduce
1036 (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
1037 | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t
1039 | Cic.Appl [] -> assert false
1040 | Cic.Appl (he::tl) -> hd_delta_beta context tl he
1041 | t -> cannot_delta_expand t
1043 let context_and_matched_term_list =
1045 None -> [context, where]
1048 ProofEngineHelpers.locate_in_term
1049 ~equality:first_is_the_expandable_head_of_second
1054 (ProofEngineTypes.Fail
1055 (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where)))
1061 (function (context,where) -> hd_delta_beta context [] where)
1062 context_and_matched_term_list in
1063 let whats = List.map snd context_and_matched_term_list in
1064 replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where