helm/ocaml/cic_unification/cicUnification.ml

   1 (* Copyright (C) 2000, 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 exception UnificationFailed;;
  27 exception Free;;
  28 exception OccurCheck;;
  29 exception RelToHiddenHypothesis;;
  30 exception OpenTerm;;
  31
  32 (**** DELIFT ****)
  33
  34 (* the delift function takes in input an ordered list of optional terms       *)
  35 (* [t1,...,tn] and a term t, and substitutes every tk = Some (rel(nk)) with   *)
  36 (* rel(k). Typically, the list of optional terms is the explicit substitution *)(* that is applied to a metavariable occurrence and the result of the delift  *)
  37 (* function is a term the implicit variable can be substituted with to make   *)
  38 (* the term [t] unifiable with the metavariable occurrence.                   *)
  39 (* In general, the problem is undecidable if we consider equivalence in place *)
  40 (* of alpha convertibility. Our implementation, though, is even weaker than   *)
  41 (* alpha convertibility, since it replace the term [tk] if and only if [tk]   *)
  42 (* is a Rel (missing all the other cases). Does this matter in practice?      *)
  43
  44 exception NotInTheList;;
  45
  46 let position n =
  47   let rec aux k =
  48    function
  49        [] -> raise NotInTheList
  50      | (Some (Cic.Rel m))::_ when m=n -> k
  51      | _::tl -> aux (k+1) tl in
  52   aux 1
  53 ;;
  54
  55 let restrict to_be_restricted =
  56   let rec erase i n =
  57     function
  58         [] -> []
  59       |        _::tl when List.mem (n,i) to_be_restricted ->
  60           None::(erase (i+1) n tl)
  61       | he::tl -> he::(erase (i+1) n tl) in
  62   let rec aux =
  63     function
  64         [] -> []
  65       |        (n,context,t)::tl -> (n,erase 1 n context,t)::(aux tl) in
  66   aux
  67 ;;
  68
  69
  70 let delift context metasenv l t =
  71  let module S = CicSubstitution in
  72   let to_be_restricted = ref [] in
  73   let rec deliftaux k =
  74    let module C = Cic in
  75     function
  76        C.Rel m ->
  77          if m <=k then
  78           C.Rel m   (*CSC: che succede se c'e' un Def? Dovrebbe averlo gia' *)
  79                     (*CSC: deliftato la regola per il LetIn                 *)
  80                     (*CSC: FALSO! La regola per il LetIn non lo fa          *)
  81          else
  82           (match List.nth context (m-k-1) with
  83             Some (_,C.Def (t,_)) ->
  84              (*CSC: Hmmm. This bit of reduction is not in the spirit of    *)
  85              (*CSC: first order unification. Does it help or does it harm? *)
  86              deliftaux k (S.lift m t)
  87           | Some (_,C.Decl t) ->
  88              (* It may augment to_be_restricted *)
  89              (*CSC: Really? Even in the case of well-typed terms?      *)
  90              (*CSC: I am no longer sure of the usefulness of the check *)
  91              ignore (deliftaux k (S.lift m t)) ;
  92              C.Rel ((position (m-k) l) + k)
  93           | None -> raise RelToHiddenHypothesis)
  94      | C.Var (uri,exp_named_subst) ->
  95         let exp_named_subst' =
  96          List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
  97         in
  98          C.Var (uri,exp_named_subst')
  99      | C.Meta (i, l1) as t ->
 100 (* CSC: BIG BUG HERE! In the explicit substitution l1 = [t1 ; t2],       *)
 101 (* CSC: it is NOT true that Rel(1) in t2 refers to t1 (i.e. the explicit *)
 102 (* CSC: substitution is simultaneous, not telescopic. To be fixes ASAP.  *)
 103         let rec deliftl j =
 104          function
 105             [] -> []
 106           | None::tl -> None::(deliftl (j+1) tl)
 107           | (Some t)::tl ->
 108              let l1' = (deliftl (j+1) tl) in
 109               try
 110                Some (deliftaux k t)::l1'
 111               with
 112                  RelToHiddenHypothesis
 113                | NotInTheList ->
 114                   to_be_restricted := (i,j)::!to_be_restricted ; None::l1'
 115         in
 116          let l' = deliftl 1 l1 in
 117           C.Meta(i,l')
 118      | C.Sort _ as t -> t
 119      | C.Implicit as t -> t
 120      | C.Cast (te,ty) -> C.Cast (deliftaux k te, deliftaux k ty)
 121      | C.Prod (n,s,t) -> C.Prod (n, deliftaux k s, deliftaux (k+1) t)
 122      | C.Lambda (n,s,t) -> C.Lambda (n, deliftaux k s, deliftaux (k+1) t)
 123      | C.LetIn (n,s,t) -> C.LetIn (n, deliftaux k s, deliftaux (k+1) t)
 124      | C.Appl l -> C.Appl (List.map (deliftaux k) l)
 125      | C.Const (uri,exp_named_subst) ->
 126         let exp_named_subst' =
 127          List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
 128         in
 129          C.Const (uri,exp_named_subst')
 130      | C.MutInd (uri,typeno,exp_named_subst) ->
 131         let exp_named_subst' =
 132          List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
 133         in
 134          C.MutInd (uri,typeno,exp_named_subst')
 135      | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
 136         let exp_named_subst' =
 137          List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
 138         in
 139          C.MutConstruct (uri,typeno,consno,exp_named_subst')
 140      | C.MutCase (sp,i,outty,t,pl) ->
 141         C.MutCase (sp, i, deliftaux k outty, deliftaux k t,
 142          List.map (deliftaux k) pl)
 143      | C.Fix (i, fl) ->
 144         let len = List.length fl in
 145         let liftedfl =
 146          List.map
 147           (fun (name, i, ty, bo) ->
 148            (name, i, deliftaux k ty, deliftaux (k+len) bo))
 149            fl
 150         in
 151          C.Fix (i, liftedfl)
 152      | C.CoFix (i, fl) ->
 153         let len = List.length fl in
 154         let liftedfl =
 155          List.map
 156           (fun (name, ty, bo) -> (name, deliftaux k ty, deliftaux (k+len) bo))
 157            fl
 158         in
 159          C.CoFix (i, liftedfl)
 160   in
 161    let res =
 162     try
 163      deliftaux 0 t
 164     with
 165      NotInTheList ->
 166       (* This is the case where we fail even first order unification. *)
 167       (* The reason is that our delift function is weaker than first  *)
 168       (* order (in the sense of alpha-conversion). See comment above  *)
 169       (* related to the delift function.                              *)
 170 prerr_endline "!!!!!!!!!!! First Order UnificationFailed, but maybe it could have been successful even in a first order setting (no conversion, only alpha convertibility)! Please, implement a better delift function !!!!!!!!!!!!!!!!" ;
 171       raise UnificationFailed
 172    in
 173     res, restrict !to_be_restricted metasenv
 174 ;;
 175
 176 (**** END OF DELIFT ****)
 177
 178 type substitution = (int * Cic.term) list
 179
 180 (* NUOVA UNIFICAZIONE *)
 181 (* A substitution is a (int * Cic.term) list that associates a
 182    metavariable i with its body.
 183    A metaenv is a (int * Cic.term) list that associate a metavariable
 184    i with is type.
 185    fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back
 186    a new substitution which is _NOT_ unwinded. It must be unwinded before
 187    applying it. *)
 188
 189 let rec fo_unif_subst subst context metasenv t1 t2 =
 190  let module C = Cic in
 191  let module R = CicReduction in
 192  let module S = CicSubstitution in
 193   match (t1, t2) with
 194      (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
 195        let ok =
 196         List.fold_left2
 197          (fun b t1 t2 ->
 198            b &&
 199             match t1,t2 with
 200                None,_
 201              | _,None -> true
 202              | Some t1', Some t2' ->
 203                 (* First possibility:  restriction    *)
 204                 (* Second possibility: unification    *)
 205                 (* Third possibility:  convertibility *)
 206                 R.are_convertible context t1' t2'
 207          ) true ln lm
 208        in
 209         if ok then subst,metasenv else raise UnificationFailed
 210    | (C.Meta (n,l), C.Meta (m,_)) when n>m ->
 211        fo_unif_subst subst context metasenv t2 t1
 212    | (C.Meta (n,l), t)
 213    | (t, C.Meta (n,l)) ->
 214        let subst',metasenv' =
 215         try
 216          let oldt = (List.assoc n subst) in
 217          let lifted_oldt = S.lift_meta l oldt in
 218           fo_unif_subst subst context metasenv lifted_oldt t
 219         with Not_found ->
 220          let t',metasenv' = delift context metasenv l t in
 221           (n, t')::subst, metasenv'
 222        in
 223         let (_,_,meta_type) =
 224          List.find (function (m,_,_) -> m=n) metasenv' in
 225         let tyt = CicTypeChecker.type_of_aux' metasenv' context t in
 226          fo_unif_subst subst' context metasenv' (S.lift_meta l meta_type) tyt
 227    | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
 228    | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
 229       if UriManager.eq uri1 uri2 then
 230        fo_unif_subst_exp_named_subst subst context metasenv
 231         exp_named_subst1 exp_named_subst2
 232       else
 233        raise UnificationFailed
 234    | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
 235       if UriManager.eq uri1 uri2 && i1 = i2 then
 236        fo_unif_subst_exp_named_subst subst context metasenv
 237         exp_named_subst1 exp_named_subst2
 238       else
 239        raise UnificationFailed
 240    | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
 241      C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
 242       if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
 243        fo_unif_subst_exp_named_subst subst context metasenv
 244         exp_named_subst1 exp_named_subst2
 245       else
 246        raise UnificationFailed
 247    | (C.Rel _, _)
 248    | (_,  C.Rel _)
 249    | (C.Sort _ ,_)
 250    | (_, C.Sort _)
 251    | (C.Implicit, _)
 252    | (_, C.Implicit) ->
 253        if R.are_convertible context t1 t2 then
 254         subst, metasenv
 255        else
 256         raise UnificationFailed
 257    | (C.Cast (te,ty), t2) -> fo_unif_subst subst context metasenv te t2
 258    | (t1, C.Cast (te,ty)) -> fo_unif_subst subst context metasenv t1 te
 259    | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
 260        let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
 261         fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
 262    | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
 263        let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
 264         fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
 265    | (C.LetIn (_,s1,t1), t2)
 266    | (t2, C.LetIn (_,s1,t1)) ->
 267        fo_unif_subst subst context metasenv t2 (S.subst s1 t1)
 268    | (C.Appl l1, C.Appl l2) ->
 269        let lr1 = List.rev l1 in
 270        let lr2 = List.rev l2 in
 271        let rec fo_unif_l subst metasenv =
 272         function
 273            [],_
 274          | _,[] -> assert false
 275          | ([h1],[h2]) ->
 276              fo_unif_subst subst context metasenv h1 h2
 277          | ([h],l)
 278          | (l,[h]) ->
 279              fo_unif_subst subst context metasenv h (C.Appl (List.rev l))
 280          | ((h1::l1),(h2::l2)) ->
 281             let subst', metasenv' =
 282              fo_unif_subst subst context metasenv h1 h2
 283             in
 284              fo_unif_l subst' metasenv' (l1,l2)
 285        in
 286         fo_unif_l subst metasenv (lr1, lr2)
 287    | (C.Const _, _)
 288    | (_, C.Const _)
 289    | (C.MutInd  _, _)
 290    | (_, C.MutInd _)
 291    | (C.MutConstruct _, _)
 292    | (_, C.MutConstruct _) ->
 293       if R.are_convertible context t1 t2 then
 294        subst, metasenv
 295       else
 296        raise UnificationFailed
 297    | (C.MutCase (_,_,outt1,t1,pl1), C.MutCase (_,_,outt2,t2,pl2))->
 298        let subst', metasenv' =
 299         fo_unif_subst subst context metasenv outt1 outt2 in
 300        let subst'',metasenv'' =
 301         fo_unif_subst subst' context metasenv' t1 t2 in
 302        List.fold_left2
 303         (function (subst,metasenv) ->
 304           fo_unif_subst subst context metasenv
 305         ) (subst'',metasenv'') pl1 pl2
 306    | (C.Fix _, _)
 307    | (_, C.Fix _)
 308    | (C.CoFix _, _)
 309    | (_, C.CoFix _) ->
 310        if R.are_convertible context t1 t2 then
 311         subst, metasenv
 312        else
 313         raise UnificationFailed
 314    | (_,_) ->
 315        if R.are_convertible context t1 t2 then
 316         subst, metasenv
 317        else
 318         raise UnificationFailed
 319
 320 and fo_unif_subst_exp_named_subst subst context metasenv
 321  exp_named_subst1 exp_named_subst2
 322 =
 323 try
 324  List.fold_left2
 325   (fun (subst,metasenv) (uri1,t1) (uri2,t2) ->
 326     assert (uri1=uri2) ;
 327     fo_unif_subst subst context metasenv t1 t2
 328   ) (subst,metasenv) exp_named_subst1 exp_named_subst2
 329 with
 330 e ->
 331 let uri = UriManager.uri_of_string "cic:/dummy.var" in
 332 prerr_endline ("@@@: " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst1)) ^
 333 " <==> " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst2))) ; raise e
 334 ;;
 335
 336 let unwind metasenv subst unwinded t =
 337  let unwinded = ref unwinded in
 338  let frozen = ref [] in
 339  let rec um_aux metasenv =
 340   let module C = Cic in
 341   let module S = CicSubstitution in
 342    function
 343       C.Rel _ as t -> t,metasenv
 344     | C.Var _  as t -> t,metasenv
 345     | C.Meta (i,l) ->
 346         (try
 347           S.lift_meta l (List.assoc i !unwinded), metasenv
 348          with Not_found ->
 349            if List.mem i !frozen then raise OccurCheck
 350            else
 351             let saved_frozen = !frozen in
 352             frozen := i::!frozen ;
 353             let res =
 354              try
 355               let t = List.assoc i subst in
 356               let t',metasenv' = um_aux metasenv t in
 357               let _,metasenv'' =
 358                let (_,canonical_context,_) =
 359                 List.find (function (m,_,_) -> m=i) metasenv
 360                in
 361                 delift canonical_context metasenv' l t'
 362               in
 363                unwinded := (i,t')::!unwinded ;
 364                S.lift_meta l t', metasenv'
 365              with
 366               Not_found ->
 367                (* not constrained variable, i.e. free in subst*)
 368                let l',metasenv' =
 369                 List.fold_right
 370                  (fun t (tl,metasenv) ->
 371                    match t with
 372                       None -> None::tl,metasenv
 373                     | Some t ->
 374                        let t',metasenv' = um_aux metasenv t in
 375                         (Some t')::tl, metasenv'
 376                  ) l ([],metasenv)
 377                in
 378                 C.Meta (i,l'), metasenv'
 379             in
 380             frozen := saved_frozen ;
 381             res
 382         )
 383     | C.Sort _
 384     | C.Implicit as t -> t,metasenv
 385     | C.Cast (te,ty) ->
 386        let te',metasenv' = um_aux metasenv te in
 387        let ty',metasenv'' = um_aux metasenv' ty in
 388        C.Cast (te',ty'),metasenv''
 389     | C.Prod (n,s,t) ->
 390        let s',metasenv' = um_aux metasenv s in
 391        let t',metasenv'' = um_aux metasenv' t in
 392        C.Prod (n, s', t'), metasenv''
 393     | C.Lambda (n,s,t) ->
 394        let s',metasenv' = um_aux metasenv s in
 395        let t',metasenv'' = um_aux metasenv' t in
 396        C.Lambda (n, s', t'), metasenv''
 397     | C.LetIn (n,s,t) ->
 398        let s',metasenv' = um_aux metasenv s in
 399        let t',metasenv'' = um_aux metasenv' t in
 400        C.LetIn (n, s', t'), metasenv''
 401     | C.Appl (he::tl) ->
 402        let tl',metasenv' =
 403         List.fold_right
 404          (fun t (tl,metasenv) ->
 405            let t',metasenv' = um_aux metasenv t in
 406             t'::tl, metasenv'
 407          ) tl ([],metasenv)
 408        in
 409         begin
 410          match um_aux metasenv' he with
 411             (C.Appl l, metasenv'') -> C.Appl (l@tl'),metasenv''
 412           | (he', metasenv'') -> C.Appl (he'::tl'),metasenv''
 413         end
 414     | C.Appl _ -> assert false
 415     | C.Const (uri,exp_named_subst) ->
 416        let exp_named_subst', metasenv' =
 417         List.fold_right
 418          (fun (uri,t) (tl,metasenv) ->
 419            let t',metasenv' = um_aux metasenv t in
 420             (uri,t')::tl, metasenv'
 421          ) exp_named_subst ([],metasenv)
 422        in
 423         C.Const (uri,exp_named_subst'),metasenv'
 424     | C.MutInd (uri,typeno,exp_named_subst) ->
 425        let exp_named_subst', metasenv' =
 426         List.fold_right
 427          (fun (uri,t) (tl,metasenv) ->
 428            let t',metasenv' = um_aux metasenv t in
 429             (uri,t')::tl, metasenv'
 430          ) exp_named_subst ([],metasenv)
 431        in
 432         C.MutInd (uri,typeno,exp_named_subst'),metasenv'
 433     | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
 434        let exp_named_subst', metasenv' =
 435         List.fold_right
 436          (fun (uri,t) (tl,metasenv) ->
 437            let t',metasenv' = um_aux metasenv t in
 438             (uri,t')::tl, metasenv'
 439          ) exp_named_subst ([],metasenv)
 440        in
 441         C.MutConstruct (uri,typeno,consno,exp_named_subst'),metasenv'
 442     | C.MutCase (sp,i,outty,t,pl) ->
 443        let outty',metasenv' = um_aux metasenv outty in
 444        let t',metasenv'' = um_aux metasenv' t in
 445        let pl',metasenv''' =
 446         List.fold_right
 447          (fun p (pl,metasenv) ->
 448            let p',metasenv' = um_aux metasenv p in
 449             p'::pl, metasenv'
 450          ) pl ([],metasenv'')
 451        in
 452         C.MutCase (sp, i, outty', t', pl'),metasenv'''
 453     | C.Fix (i, fl) ->
 454        let len = List.length fl in
 455        let liftedfl,metasenv' =
 456         List.fold_right
 457          (fun (name, i, ty, bo) (fl,metasenv) ->
 458            let ty',metasenv' = um_aux metasenv ty in
 459            let bo',metasenv'' = um_aux metasenv' bo in
 460             (name, i, ty', bo')::fl,metasenv''
 461          ) fl ([],metasenv)
 462        in
 463         C.Fix (i, liftedfl),metasenv'
 464     | C.CoFix (i, fl) ->
 465        let len = List.length fl in
 466        let liftedfl,metasenv' =
 467         List.fold_right
 468          (fun (name, ty, bo) (fl,metasenv) ->
 469            let ty',metasenv' = um_aux metasenv ty in
 470            let bo',metasenv'' = um_aux metasenv' bo in
 471             (name, ty', bo')::fl,metasenv''
 472          ) fl ([],metasenv)
 473        in
 474         C.CoFix (i, liftedfl),metasenv'
 475  in
 476   let t',metasenv' = um_aux metasenv t in
 477    t',metasenv',!unwinded
 478 ;;
 479
 480 (* apply_subst_reducing subst (Some (mtr,reductions_no)) t              *)
 481 (* performs as (apply_subst subst t) until it finds an application of   *)
 482 (* (META [meta_to_reduce]) that, once unwinding is performed, creates   *)
 483 (* a new beta-redex; in this case up to [reductions_no] consecutive     *)
 484 (* beta-reductions are performed.                                       *)
 485 (* Hint: this function is usually called when [reductions_no]           *)
 486 (*  eta-expansions have been performed and the head of the new          *)
 487 (*  application has been unified with (META [meta_to_reduce]):          *)
 488 (*  during the unwinding the eta-expansions are undone.                 *)
 489
 490 let apply_subst_reducing subst meta_to_reduce t =
 491  let unwinded = ref subst in
 492  let rec um_aux =
 493   let module C = Cic in
 494   let module S = CicSubstitution in
 495    function
 496       C.Rel _
 497     | C.Var _  as t -> t
 498     | C.Meta (i,l) as t ->
 499        (try
 500          S.lift_meta l (List.assoc i !unwinded)
 501         with Not_found ->
 502           C.Meta (i,l))
 503     | C.Sort _ as t -> t
 504     | C.Implicit as t -> t
 505     | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty)
 506     | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t)
 507     | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t)
 508     | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t)
 509     | C.Appl (he::tl) ->
 510        let tl' = List.map um_aux tl in
 511         let t' =
 512          match um_aux he with
 513             C.Appl l -> C.Appl (l@tl')
 514           | _ as he' -> C.Appl (he'::tl')
 515         in
 516          begin
 517           match meta_to_reduce,he with
 518              Some (mtr,reductions_no), C.Meta (m,_) when m = mtr ->
 519               let rec beta_reduce =
 520                function
 521                   (n,(C.Appl (C.Lambda (_,_,t)::he'::tl'))) when n > 0 ->
 522                     let he'' = CicSubstitution.subst he' t in
 523                      if tl' = [] then
 524                       he''
 525                      else
 526                       beta_reduce (n-1,C.Appl(he''::tl'))
 527                 | (_,t) -> t
 528               in
 529                beta_reduce (reductions_no,t')
 530            | _,_ -> t'
 531          end
 532     | C.Appl _ -> assert false
 533     | C.Const (uri,exp_named_subst) ->
 534        let exp_named_subst' =
 535         List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
 536        in
 537         C.Const (uri,exp_named_subst')
 538     | C.MutInd (uri,typeno,exp_named_subst) ->
 539        let exp_named_subst' =
 540         List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
 541        in
 542         C.MutInd (uri,typeno,exp_named_subst')
 543     | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
 544        let exp_named_subst' =
 545         List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
 546        in
 547         C.MutConstruct (uri,typeno,consno,exp_named_subst')
 548     | C.MutCase (sp,i,outty,t,pl) ->
 549        C.MutCase (sp, i, um_aux outty, um_aux t,
 550         List.map um_aux pl)
 551     | C.Fix (i, fl) ->
 552        let len = List.length fl in
 553        let liftedfl =
 554         List.map
 555          (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo))
 556           fl
 557        in
 558         C.Fix (i, liftedfl)
 559     | C.CoFix (i, fl) ->
 560        let len = List.length fl in
 561        let liftedfl =
 562         List.map
 563          (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo))
 564           fl
 565        in
 566         C.CoFix (i, liftedfl)
 567  in
 568    um_aux t
 569 ;;
 570
 571 (* UNWIND THE MGU INSIDE THE MGU *)
 572 let unwind_subst metasenv subst =
 573  let identity_relocation_list_for_metavariable i =
 574   let (_,canonical_context,_) =
 575    List.find (function (m,_,_) -> m=i) metasenv
 576   in
 577    let canonical_context_length = List.length canonical_context in
 578     let rec aux =
 579      function
 580         n when n > canonical_context_length -> []
 581       | n -> (Some (Cic.Rel n))::(aux (n+1))
 582     in
 583      aux 1
 584  in
 585   List.fold_left
 586    (fun (unwinded,metasenv) (i,_) ->
 587      let identity_relocation_list =
 588       identity_relocation_list_for_metavariable i
 589      in
 590       let (_,metasenv',subst') =
 591        unwind metasenv subst unwinded (Cic.Meta (i,identity_relocation_list))
 592       in
 593        subst',metasenv'
 594    ) ([],metasenv) subst
 595 ;;
 596
 597 let apply_subst subst t =
 598  (* metasenv will not be used nor modified. So, let's use a dummy empty one *)
 599  let metasenv = [] in
 600   let (t',_,_) = unwind metasenv [] subst t in
 601    t'
 602 ;;
 603
 604 (* A substitution is a (int * Cic.term) list that associates a               *)
 605 (* metavariable i with its body.                                             *)
 606 (* metasenv is of type Cic.metasenv                                          *)
 607 (* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back   *)
 608 (* a new substitution which is already unwinded and ready to be applied and  *)
 609 (* a new metasenv in which some hypothesis in the contexts of the            *)
 610 (* metavariables may have been restricted.                                   *)
 611 let fo_unif metasenv context t1 t2 =
 612  let subst_to_unwind,metasenv' = fo_unif_subst [] context metasenv t1 t2 in
 613   unwind_subst metasenv' subst_to_unwind
 614 ;;