1 (* Copyright (C) 2000, 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 exception UnificationFailed;;
28 exception OccurCheck;;
29 exception RelToHiddenHypothesis;;
34 (* the delift function takes in input an ordered list of integers [n1,...,nk]
35 and a term t, and relocates rel(nk) to k. Typically, the list of integers
36 is a parameter of a metavariable occurrence. *)
38 exception NotInTheList;;
43 [] -> raise NotInTheList
44 | (Some (Cic.Rel m))::_ when m=n -> k
45 | _::tl -> aux (k+1) tl in
49 let restrict to_be_restricted =
53 | _::tl when List.mem (n,i) to_be_restricted ->
54 None::(erase (i+1) n tl)
55 | he::tl -> he::(erase (i+1) n tl) in
59 | (n,context,t)::tl -> (n,erase 1 n context,t)::(aux tl) in
64 let delift context metasenv l t =
65 let module S = CicSubstitution in
66 let to_be_restricted = ref [] in
72 C.Rel m (*CSC: che succede se c'e' un Def? Dovrebbe averlo gia' *)
73 (*CSC: deliftato la regola per il LetIn *)
75 (match List.nth context (m-k-1) with
76 Some (_,C.Def (t,_)) -> deliftaux k (S.lift m t)
77 | Some (_,C.Decl t) ->
78 (* It may augment to_be_restricted *)
79 ignore (deliftaux k (S.lift m t)) ;
80 C.Rel ((position (m-k) l) + k)
81 | None -> raise RelToHiddenHypothesis)
82 | C.Var (uri,exp_named_subst) ->
83 let exp_named_subst' =
84 List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
86 C.Var (uri,exp_named_subst')
87 | C.Meta (i, l1) as t ->
91 | None::tl -> None::(deliftl (j+1) tl)
93 let l1' = (deliftl (j+1) tl) in
95 Some (deliftaux k t)::l1'
99 to_be_restricted := (i,j)::!to_be_restricted ; None::l1'
101 let l' = deliftl 1 l1 in
104 | C.Implicit as t -> t
105 | C.Cast (te,ty) -> C.Cast (deliftaux k te, deliftaux k ty)
106 | C.Prod (n,s,t) -> C.Prod (n, deliftaux k s, deliftaux (k+1) t)
107 | C.Lambda (n,s,t) -> C.Lambda (n, deliftaux k s, deliftaux (k+1) t)
108 | C.LetIn (n,s,t) -> C.LetIn (n, deliftaux k s, deliftaux (k+1) t)
109 | C.Appl l -> C.Appl (List.map (deliftaux k) l)
110 | C.Const (uri,exp_named_subst) ->
111 let exp_named_subst' =
112 List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
114 C.Const (uri,exp_named_subst')
115 | C.MutInd (uri,typeno,exp_named_subst) ->
116 let exp_named_subst' =
117 List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
119 C.MutInd (uri,typeno,exp_named_subst')
120 | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
121 let exp_named_subst' =
122 List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
124 C.MutConstruct (uri,typeno,consno,exp_named_subst')
125 | C.MutCase (sp,i,outty,t,pl) ->
126 C.MutCase (sp, i, deliftaux k outty, deliftaux k t,
127 List.map (deliftaux k) pl)
129 let len = List.length fl in
132 (fun (name, i, ty, bo) ->
133 (name, i, deliftaux k ty, deliftaux (k+len) bo))
138 let len = List.length fl in
141 (fun (name, ty, bo) -> (name, deliftaux k ty, deliftaux (k+len) bo))
144 C.CoFix (i, liftedfl)
146 let res = deliftaux 0 t in
147 res, restrict !to_be_restricted metasenv
150 (**** END OF DELIFT ****)
152 type substitution = (int * Cic.term) list
154 (* NUOVA UNIFICAZIONE *)
155 (* A substitution is a (int * Cic.term) list that associates a
156 metavariable i with its body.
157 A metaenv is a (int * Cic.term) list that associate a metavariable
159 fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back
160 a new substitution which is _NOT_ unwinded. It must be unwinded before
163 let rec fo_unif_subst subst context metasenv t1 t2 =
164 let module C = Cic in
165 let module R = CicReduction in
166 let module S = CicSubstitution in
168 (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
176 | Some t1', Some t2' ->
177 (* First possibility: restriction *)
178 (* Second possibility: unification *)
179 (* Third possibility: convertibility *)
180 R.are_convertible context t1' t2'
183 if ok then subst,metasenv else raise UnificationFailed
184 | (C.Meta (n,l), C.Meta (m,_)) when n>m ->
185 fo_unif_subst subst context metasenv t2 t1
187 | (t, C.Meta (n,l)) ->
188 let subst',metasenv' =
190 let oldt = (List.assoc n subst) in
191 let lifted_oldt = S.lift_meta l oldt in
192 fo_unif_subst subst context metasenv lifted_oldt t
194 let t',metasenv' = delift context metasenv l t in
195 (n, t')::subst, metasenv'
197 let (_,_,meta_type) =
198 List.find (function (m,_,_) -> m=n) metasenv' in
199 let tyt = CicTypeChecker.type_of_aux' metasenv' context t in
200 fo_unif_subst subst' context metasenv' (S.lift_meta l meta_type) tyt
201 | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
202 | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
203 if UriManager.eq uri1 uri2 then
204 fo_unif_subst_exp_named_subst subst context metasenv
205 exp_named_subst1 exp_named_subst2
207 raise UnificationFailed
208 | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
209 if UriManager.eq uri1 uri2 && i1 = i2 then
210 fo_unif_subst_exp_named_subst subst context metasenv
211 exp_named_subst1 exp_named_subst2
213 raise UnificationFailed
214 | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
215 C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
216 if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
217 fo_unif_subst_exp_named_subst subst context metasenv
218 exp_named_subst1 exp_named_subst2
220 raise UnificationFailed
227 if R.are_convertible context t1 t2 then
230 raise UnificationFailed
231 | (C.Cast (te,ty), t2) -> fo_unif_subst subst context metasenv te t2
232 | (t1, C.Cast (te,ty)) -> fo_unif_subst subst context metasenv t1 te
233 | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
234 let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
235 fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
236 | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
237 let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
238 fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
239 | (C.LetIn (_,s1,t1), t2)
240 | (t2, C.LetIn (_,s1,t1)) ->
241 fo_unif_subst subst context metasenv t2 (S.subst s1 t1)
242 | (C.Appl l1, C.Appl l2) ->
243 let lr1 = List.rev l1 in
244 let lr2 = List.rev l2 in
245 let rec fo_unif_l subst metasenv =
248 | _,[] -> assert false
250 fo_unif_subst subst context metasenv h1 h2
253 fo_unif_subst subst context metasenv h (C.Appl (List.rev l))
254 | ((h1::l1),(h2::l2)) ->
255 let subst', metasenv' =
256 fo_unif_subst subst context metasenv h1 h2
258 fo_unif_l subst' metasenv' (l1,l2)
260 fo_unif_l subst metasenv (lr1, lr2)
265 | (C.MutConstruct _, _)
266 | (_, C.MutConstruct _) ->
267 if R.are_convertible context t1 t2 then
270 raise UnificationFailed
271 | (C.MutCase (_,_,outt1,t1,pl1), C.MutCase (_,_,outt2,t2,pl2))->
272 let subst', metasenv' =
273 fo_unif_subst subst context metasenv outt1 outt2 in
274 let subst'',metasenv'' =
275 fo_unif_subst subst' context metasenv' t1 t2 in
277 (function (subst,metasenv) ->
278 fo_unif_subst subst context metasenv
279 ) (subst'',metasenv'') pl1 pl2
284 if R.are_convertible context t1 t2 then
287 raise UnificationFailed
289 if R.are_convertible context t1 t2 then
292 raise UnificationFailed
294 and fo_unif_subst_exp_named_subst subst context metasenv
295 exp_named_subst1 exp_named_subst2
299 (fun (subst,metasenv) (uri1,t1) (uri2,t2) ->
301 fo_unif_subst subst context metasenv t1 t2
302 ) (subst,metasenv) exp_named_subst1 exp_named_subst2
305 let uri = UriManager.uri_of_string "cic:/dummy.var" in
306 prerr_endline ("@@@: " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst1)) ^
307 " <==> " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst2))) ; raise e
310 let unwind metasenv subst unwinded t =
311 let unwinded = ref unwinded in
312 let frozen = ref [] in
313 let rec um_aux metasenv =
314 let module C = Cic in
315 let module S = CicSubstitution in
317 C.Rel _ as t -> t,metasenv
318 | C.Var _ as t -> t,metasenv
321 S.lift_meta l (List.assoc i !unwinded), metasenv
323 if List.mem i !frozen then raise OccurCheck
325 let saved_frozen = !frozen in
326 frozen := i::!frozen ;
329 let t = List.assoc i subst in
330 let t',metasenv' = um_aux metasenv t in
332 let (_,canonical_context,_) =
333 List.find (function (m,_,_) -> m=i) metasenv
335 delift canonical_context metasenv' l t'
337 unwinded := (i,t')::!unwinded ;
338 S.lift_meta l t', metasenv'
341 (* not constrained variable, i.e. free in subst*)
344 (fun t (tl,metasenv) ->
346 None -> None::tl,metasenv
348 let t',metasenv' = um_aux metasenv t in
349 (Some t')::tl, metasenv'
352 C.Meta (i,l'), metasenv'
354 frozen := saved_frozen ;
358 | C.Implicit as t -> t,metasenv
360 let te',metasenv' = um_aux metasenv te in
361 let ty',metasenv'' = um_aux metasenv' ty in
362 C.Cast (te',ty'),metasenv''
364 let s',metasenv' = um_aux metasenv s in
365 let t',metasenv'' = um_aux metasenv' t in
366 C.Prod (n, s', t'), metasenv''
367 | C.Lambda (n,s,t) ->
368 let s',metasenv' = um_aux metasenv s in
369 let t',metasenv'' = um_aux metasenv' t in
370 C.Lambda (n, s', t'), metasenv''
372 let s',metasenv' = um_aux metasenv s in
373 let t',metasenv'' = um_aux metasenv' t in
374 C.LetIn (n, s', t'), metasenv''
378 (fun t (tl,metasenv) ->
379 let t',metasenv' = um_aux metasenv t in
384 match um_aux metasenv' he with
385 (C.Appl l, metasenv'') -> C.Appl (l@tl'),metasenv''
386 | (he', metasenv'') -> C.Appl (he'::tl'),metasenv''
388 | C.Appl _ -> assert false
389 | C.Const (uri,exp_named_subst) ->
390 let exp_named_subst', metasenv' =
392 (fun (uri,t) (tl,metasenv) ->
393 let t',metasenv' = um_aux metasenv t in
394 (uri,t')::tl, metasenv'
395 ) exp_named_subst ([],metasenv)
397 C.Const (uri,exp_named_subst'),metasenv'
398 | C.MutInd (uri,typeno,exp_named_subst) ->
399 let exp_named_subst', metasenv' =
401 (fun (uri,t) (tl,metasenv) ->
402 let t',metasenv' = um_aux metasenv t in
403 (uri,t')::tl, metasenv'
404 ) exp_named_subst ([],metasenv)
406 C.MutInd (uri,typeno,exp_named_subst'),metasenv'
407 | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
408 let exp_named_subst', metasenv' =
410 (fun (uri,t) (tl,metasenv) ->
411 let t',metasenv' = um_aux metasenv t in
412 (uri,t')::tl, metasenv'
413 ) exp_named_subst ([],metasenv)
415 C.MutConstruct (uri,typeno,consno,exp_named_subst'),metasenv'
416 | C.MutCase (sp,i,outty,t,pl) ->
417 let outty',metasenv' = um_aux metasenv outty in
418 let t',metasenv'' = um_aux metasenv' t in
419 let pl',metasenv''' =
421 (fun p (pl,metasenv) ->
422 let p',metasenv' = um_aux metasenv p in
426 C.MutCase (sp, i, outty', t', pl'),metasenv'''
428 let len = List.length fl in
429 let liftedfl,metasenv' =
431 (fun (name, i, ty, bo) (fl,metasenv) ->
432 let ty',metasenv' = um_aux metasenv ty in
433 let bo',metasenv'' = um_aux metasenv' bo in
434 (name, i, ty', bo')::fl,metasenv''
437 C.Fix (i, liftedfl),metasenv'
439 let len = List.length fl in
440 let liftedfl,metasenv' =
442 (fun (name, ty, bo) (fl,metasenv) ->
443 let ty',metasenv' = um_aux metasenv ty in
444 let bo',metasenv'' = um_aux metasenv' bo in
445 (name, ty', bo')::fl,metasenv''
448 C.CoFix (i, liftedfl),metasenv'
450 let t',metasenv' = um_aux metasenv t in
451 t',metasenv',!unwinded
454 (* apply_subst_reducing subst (Some (mtr,reductions_no)) t *)
455 (* performs as (apply_subst subst t) until it finds an application of *)
456 (* (META [meta_to_reduce]) that, once unwinding is performed, creates *)
457 (* a new beta-redex; in this case up to [reductions_no] consecutive *)
458 (* beta-reductions are performed. *)
459 (* Hint: this function is usually called when [reductions_no] *)
460 (* eta-expansions have been performed and the head of the new *)
461 (* application has been unified with (META [meta_to_reduce]): *)
462 (* during the unwinding the eta-expansions are undone. *)
464 let apply_subst_reducing subst meta_to_reduce t =
465 let unwinded = ref subst in
467 let module C = Cic in
468 let module S = CicSubstitution in
472 | C.Meta (i,l) as t ->
474 S.lift_meta l (List.assoc i !unwinded)
478 | C.Implicit as t -> t
479 | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty)
480 | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t)
481 | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t)
482 | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t)
484 let tl' = List.map um_aux tl in
487 C.Appl l -> C.Appl (l@tl')
488 | _ as he' -> C.Appl (he'::tl')
491 match meta_to_reduce,he with
492 Some (mtr,reductions_no), C.Meta (m,_) when m = mtr ->
493 let rec beta_reduce =
495 (n,(C.Appl (C.Lambda (_,_,t)::he'::tl'))) when n > 0 ->
496 let he'' = CicSubstitution.subst he' t in
500 beta_reduce (n-1,C.Appl(he''::tl'))
503 beta_reduce (reductions_no,t')
506 | C.Appl _ -> assert false
507 | C.Const (uri,exp_named_subst) ->
508 let exp_named_subst' =
509 List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
511 C.Const (uri,exp_named_subst')
512 | C.MutInd (uri,typeno,exp_named_subst) ->
513 let exp_named_subst' =
514 List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
516 C.MutInd (uri,typeno,exp_named_subst')
517 | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
518 let exp_named_subst' =
519 List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
521 C.MutConstruct (uri,typeno,consno,exp_named_subst')
522 | C.MutCase (sp,i,outty,t,pl) ->
523 C.MutCase (sp, i, um_aux outty, um_aux t,
526 let len = List.length fl in
529 (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo))
534 let len = List.length fl in
537 (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo))
540 C.CoFix (i, liftedfl)
545 (* UNWIND THE MGU INSIDE THE MGU *)
546 let unwind_subst metasenv subst =
547 let identity_relocation_list_for_metavariable i =
548 let (_,canonical_context,_) =
549 List.find (function (m,_,_) -> m=i) metasenv
551 let canonical_context_length = List.length canonical_context in
554 n when n > canonical_context_length -> []
555 | n -> (Some (Cic.Rel n))::(aux (n+1))
560 (fun (unwinded,metasenv) (i,_) ->
561 let identity_relocation_list =
562 identity_relocation_list_for_metavariable i
564 let (_,metasenv',subst') =
565 unwind metasenv subst unwinded (Cic.Meta (i,identity_relocation_list))
568 ) ([],metasenv) subst
571 let apply_subst subst t =
572 (* metasenv will not be used nor modified. So, let's use a dummy empty one *)
574 let (t',_,_) = unwind metasenv [] subst t in
578 (* A substitution is a (int * Cic.term) list that associates a *)
579 (* metavariable i with its body. *)
580 (* metasenv is of type Cic.metasenv *)
581 (* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back *)
582 (* a new substitution which is already unwinded and ready to be applied and *)
583 (* a new metasenv in which some hypothesis in the contexts of the *)
584 (* metavariables may have been restricted. *)
585 let fo_unif metasenv context t1 t2 =
586 let subst_to_unwind,metasenv' = fo_unif_subst [] context metasenv t1 t2 in
587 unwind_subst metasenv' subst_to_unwind