helm/gTopLevel/proofEngineReduction.ml

   1 (* Copyright (C) 2002, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 (******************************************************************************)
  27 (*                                                                            *)
  28 (*                               PROJECT HELM                                 *)
  29 (*                                                                            *)
  30 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
  31 (*                                 12/04/2002                                 *)
  32 (*                                                                            *)
  33 (*                                                                            *)
  34 (******************************************************************************)
  35
  36
  37 (* The code of this module is derived from the code of CicReduction *)
  38
  39 exception Impossible of int;;
  40 exception ReferenceToConstant;;
  41 exception ReferenceToVariable;;
  42 exception ReferenceToCurrentProof;;
  43 exception ReferenceToInductiveDefinition;;
  44 exception WrongUriToInductiveDefinition;;
  45 exception WrongUriToConstant;;
  46 exception RelToHiddenHypothesis;;
  47
  48 let alpha_equivalence =
  49  let module C = Cic in
  50   let rec aux t t' =
  51    if t = t' then true
  52    else
  53     match t,t' with
  54        C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2) ->
  55         UriManager.eq uri1 uri2 &&
  56          aux_exp_named_subst exp_named_subst1 exp_named_subst2
  57      | C.Cast (te,ty), C.Cast (te',ty') ->
  58         aux te te' && aux ty ty'
  59      | C.Prod (_,s,t), C.Prod (_,s',t') ->
  60         aux s s' && aux t t'
  61      | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
  62         aux s s' && aux t t'
  63      | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
  64         aux s s' && aux t t'
  65      | C.Appl l, C.Appl l' ->
  66         (try
  67           List.fold_left2
  68            (fun b t1 t2 -> b && aux t1 t2) true l l'
  69          with
  70           Invalid_argument _ -> false)
  71      | C.Const (uri,exp_named_subst1), C.Const (uri',exp_named_subst2) ->
  72         UriManager.eq uri uri' &&
  73          aux_exp_named_subst exp_named_subst1 exp_named_subst2
  74      | C.MutInd (uri,i,exp_named_subst1), C.MutInd (uri',i',exp_named_subst2) ->
  75         UriManager.eq uri uri' && i = i' &&
  76          aux_exp_named_subst exp_named_subst1 exp_named_subst2
  77      | C.MutConstruct (uri,i,j,exp_named_subst1),
  78        C.MutConstruct (uri',i',j',exp_named_subst2) ->
  79         UriManager.eq uri uri' && i = i' && j = j' &&
  80          aux_exp_named_subst exp_named_subst1 exp_named_subst2
  81      | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
  82         UriManager.eq sp sp' && i = i' &&
  83          aux outt outt' && aux t t' &&
  84           (try
  85             List.fold_left2
  86              (fun b t1 t2 -> b && aux t1 t2) true pl pl'
  87            with
  88             Invalid_argument _ -> false)
  89      | C.Fix (i,fl), C.Fix (i',fl') ->
  90         i = i' &&
  91         (try
  92           List.fold_left2
  93            (fun b (_,i,ty,bo) (_,i',ty',bo') ->
  94              b && i = i' && aux ty ty' && aux bo bo'
  95            ) true fl fl'
  96          with
  97           Invalid_argument _ -> false)
  98      | C.CoFix (i,fl), C.CoFix (i',fl') ->
  99         i = i' &&
 100         (try
 101           List.fold_left2
 102            (fun b (_,ty,bo) (_,ty',bo') ->
 103              b && aux ty ty' && aux bo bo'
 104            ) true fl fl'
 105          with
 106           Invalid_argument _ -> false)
 107      | _,_ -> false (* we already know that t != t' *)
 108   and aux_exp_named_subst exp_named_subst1 exp_named_subst2 =
 109    try
 110      List.fold_left2
 111       (fun b (uri1,t1) (uri2,t2) ->
 112         b && UriManager.eq uri1 uri2 && aux t1 t2
 113       ) true exp_named_subst1 exp_named_subst2
 114     with
 115      Invalid_argument _ -> false
 116   in
 117    aux
 118 ;;
 119
 120 (* "textual" replacement of a subterm with another one *)
 121 let replace ~equality ~what ~with_what ~where =
 122  let module C = Cic in
 123   let rec aux =
 124    function
 125       t when (equality t what) -> with_what
 126     | C.Rel _ as t -> t
 127     | C.Var (uri,exp_named_subst) ->
 128        C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 129     | C.Meta _ as t -> t
 130     | C.Sort _ as t -> t
 131     | C.Implicit as t -> t
 132     | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
 133     | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
 134     | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
 135     | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
 136     | C.Appl l ->
 137        (* Invariant enforced: no application of an application *)
 138        (match List.map aux l with
 139            (C.Appl l')::tl -> C.Appl (l'@tl)
 140          | l' -> C.Appl l')
 141     | C.Const (uri,exp_named_subst) ->
 142        C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 143     | C.MutInd (uri,i,exp_named_subst) ->
 144        C.MutInd
 145         (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 146     | C.MutConstruct (uri,i,j,exp_named_subst) ->
 147        C.MutConstruct
 148         (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 149     | C.MutCase (sp,i,outt,t,pl) ->
 150        C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
 151     | C.Fix (i,fl) ->
 152        let substitutedfl =
 153         List.map
 154          (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
 155           fl
 156        in
 157         C.Fix (i, substitutedfl)
 158     | C.CoFix (i,fl) ->
 159        let substitutedfl =
 160         List.map
 161          (fun (name,ty,bo) -> (name, aux ty, aux bo))
 162           fl
 163        in
 164         C.CoFix (i, substitutedfl)
 165   in
 166    aux where
 167 ;;
 168
 169 (* replaces in a term a term with another one. *)
 170 (* Lifting are performed as usual.             *)
 171 let replace_lifting ~equality ~what ~with_what ~where =
 172  let rec substaux k what =
 173   let module C = Cic in
 174   let module S = CicSubstitution in
 175    function
 176       t when (equality t what) -> S.lift (k-1) with_what
 177     | C.Rel n as t -> t
 178     | C.Var (uri,exp_named_subst) ->
 179        let exp_named_subst' =
 180         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 181        in
 182         C.Var (uri,exp_named_subst')
 183     | C.Meta (i, l) as t ->
 184        let l' =
 185         List.map
 186          (function
 187              None -> None
 188            | Some t -> Some (substaux k what t)
 189          ) l
 190        in
 191         C.Meta(i,l')
 192     | C.Sort _ as t -> t
 193     | C.Implicit as t -> t
 194     | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
 195     | C.Prod (n,s,t) ->
 196        C.Prod (n, substaux k what s, substaux (k + 1) (S.lift 1 what) t)
 197     | C.Lambda (n,s,t) ->
 198        C.Lambda (n, substaux k what s, substaux (k + 1) (S.lift 1 what) t)
 199     | C.LetIn (n,s,t) ->
 200        C.LetIn (n, substaux k what s, substaux (k + 1) (S.lift 1 what) t)
 201     | C.Appl (he::tl) ->
 202        (* Invariant: no Appl applied to another Appl *)
 203        let tl' = List.map (substaux k what) tl in
 204         begin
 205          match substaux k what he with
 206             C.Appl l -> C.Appl (l@tl')
 207           | _ as he' -> C.Appl (he'::tl')
 208         end
 209     | C.Appl _ -> assert false
 210     | C.Const (uri,exp_named_subst) ->
 211        let exp_named_subst' =
 212         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 213        in
 214        C.Const (uri,exp_named_subst')
 215     | C.MutInd (uri,i,exp_named_subst) ->
 216        let exp_named_subst' =
 217         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 218        in
 219         C.MutInd (uri,i,exp_named_subst')
 220     | C.MutConstruct (uri,i,j,exp_named_subst) ->
 221        let exp_named_subst' =
 222         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 223        in
 224         C.MutConstruct (uri,i,j,exp_named_subst')
 225     | C.MutCase (sp,i,outt,t,pl) ->
 226        C.MutCase (sp,i,substaux k what outt, substaux k what t,
 227         List.map (substaux k what) pl)
 228     | C.Fix (i,fl) ->
 229        let len = List.length fl in
 230        let substitutedfl =
 231         List.map
 232          (fun (name,i,ty,bo) ->
 233            (name, i, substaux k what ty, substaux (k+len) (S.lift len what) bo))
 234           fl
 235        in
 236         C.Fix (i, substitutedfl)
 237     | C.CoFix (i,fl) ->
 238        let len = List.length fl in
 239        let substitutedfl =
 240         List.map
 241          (fun (name,ty,bo) ->
 242            (name, substaux k what ty, substaux (k+len) (S.lift len what) bo))
 243           fl
 244        in
 245         C.CoFix (i, substitutedfl)
 246  in
 247   substaux 1 what where
 248 ;;
 249
 250 (* Takes a well-typed term and fully reduces it. *)
 251 (*CSC: It does not perform reduction in a Case *)
 252 let reduce context =
 253  let rec reduceaux context l =
 254   let module C = Cic in
 255   let module S = CicSubstitution in
 256    function
 257       C.Rel n as t ->
 258        (match List.nth context (n-1) with
 259            Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
 260          | Some (_,C.Def bo) -> reduceaux context l (S.lift n bo)
 261          | None -> raise RelToHiddenHypothesis
 262        )
 263     | C.Var (uri,exp_named_subst) ->
 264        let exp_named_subst' =
 265         reduceaux_exp_named_subst context l exp_named_subst
 266        in
 267        (match CicEnvironment.get_obj uri with
 268            C.Constant _ -> raise ReferenceToConstant
 269          | C.CurrentProof _ -> raise ReferenceToCurrentProof
 270          | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 271          | C.Variable (_,None,_,_) ->
 272             let t' = C.Var (uri,exp_named_subst') in
 273              if l = [] then t' else C.Appl (t'::l)
 274          | C.Variable (_,Some body,_,_) ->
 275             (reduceaux context l
 276               (CicSubstitution.subst_vars exp_named_subst' body))
 277        )
 278     | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
 279     | C.Sort _ as t -> t (* l should be empty *)
 280     | C.Implicit as t -> t
 281     | C.Cast (te,ty) ->
 282        C.Cast (reduceaux context l te, reduceaux context l ty)
 283     | C.Prod (name,s,t) ->
 284        assert (l = []) ;
 285        C.Prod (name,
 286         reduceaux context [] s,
 287         reduceaux ((Some (name,C.Decl s))::context) [] t)
 288     | C.Lambda (name,s,t) ->
 289        (match l with
 290            [] ->
 291             C.Lambda (name,
 292              reduceaux context [] s,
 293              reduceaux ((Some (name,C.Decl s))::context) [] t)
 294          | he::tl -> reduceaux context tl (S.subst he t)
 295            (* when name is Anonimous the substitution should be superfluous *)
 296        )
 297     | C.LetIn (n,s,t) ->
 298        reduceaux context l (S.subst (reduceaux context [] s) t)
 299     | C.Appl (he::tl) ->
 300        let tl' = List.map (reduceaux context []) tl in
 301         reduceaux context (tl'@l) he
 302     | C.Appl [] -> raise (Impossible 1)
 303     | C.Const (uri,exp_named_subst) ->
 304        let exp_named_subst' =
 305         reduceaux_exp_named_subst context l exp_named_subst
 306        in
 307         (match CicEnvironment.get_obj uri with
 308             C.Constant (_,Some body,_,_) ->
 309              (reduceaux context l
 310                (CicSubstitution.subst_vars exp_named_subst' body))
 311           | C.Constant (_,None,_,_) ->
 312              let t' = C.Const (uri,exp_named_subst') in
 313               if l = [] then t' else C.Appl (t'::l)
 314           | C.Variable _ -> raise ReferenceToVariable
 315           | C.CurrentProof (_,_,body,_,_) ->
 316              (reduceaux context l
 317                (CicSubstitution.subst_vars exp_named_subst' body))
 318           | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 319         )
 320     | C.MutInd (uri,i,exp_named_subst) ->
 321        let exp_named_subst' =
 322         reduceaux_exp_named_subst context l exp_named_subst
 323        in
 324         let t' = C.MutInd (uri,i,exp_named_subst') in
 325          if l = [] then t' else C.Appl (t'::l)
 326     | C.MutConstruct (uri,i,j,exp_named_subst) as t ->
 327        let exp_named_subst' =
 328         reduceaux_exp_named_subst context l exp_named_subst
 329        in
 330         let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
 331          if l = [] then t' else C.Appl (t'::l)
 332     | C.MutCase (mutind,i,outtype,term,pl) ->
 333        let decofix =
 334         function
 335            C.CoFix (i,fl) as t ->
 336             let tys =
 337              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 338             in
 339              let (_,_,body) = List.nth fl i in
 340               let body' =
 341                let counter = ref (List.length fl) in
 342                 List.fold_right
 343                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 344                  fl
 345                  body
 346               in
 347                reduceaux (tys@context) [] body'
 348          | C.Appl (C.CoFix (i,fl) :: tl) ->
 349             let tys =
 350              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 351             in
 352              let (_,_,body) = List.nth fl i in
 353               let body' =
 354                let counter = ref (List.length fl) in
 355                 List.fold_right
 356                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 357                  fl
 358                  body
 359               in
 360                let tl' = List.map (reduceaux context []) tl in
 361                 reduceaux (tys@context) tl' body'
 362          | t -> t
 363        in
 364         (match decofix (reduceaux context [] term) with
 365             C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
 366           | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
 367              let (arity, r) =
 368               match CicEnvironment.get_obj mutind with
 369                  C.InductiveDefinition (tl,_,r) ->
 370                    let (_,_,arity,_) = List.nth tl i in
 371                     (arity,r)
 372                | _ -> raise WrongUriToInductiveDefinition
 373              in
 374               let ts =
 375                let rec eat_first =
 376                 function
 377                    (0,l) -> l
 378                  | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
 379                  | _ -> raise (Impossible 5)
 380                in
 381                 eat_first (r,tl)
 382               in
 383                reduceaux context (ts@l) (List.nth pl (j-1))
 384          | C.Cast _ | C.Implicit ->
 385             raise (Impossible 2) (* we don't trust our whd ;-) *)
 386          | _ ->
 387            let outtype' = reduceaux context [] outtype in
 388            let term' = reduceaux context [] term in
 389            let pl' = List.map (reduceaux context []) pl in
 390             let res =
 391              C.MutCase (mutind,i,outtype',term',pl')
 392             in
 393              if l = [] then res else C.Appl (res::l)
 394        )
 395     | C.Fix (i,fl) ->
 396        let tys =
 397         List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 398        in
 399         let t' () =
 400          let fl' =
 401           List.map
 402            (function (n,recindex,ty,bo) ->
 403              (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 404            ) fl
 405          in
 406           C.Fix (i, fl')
 407         in
 408          let (_,recindex,_,body) = List.nth fl i in
 409           let recparam =
 410            try
 411             Some (List.nth l recindex)
 412            with
 413             _ -> None
 414           in
 415            (match recparam with
 416                Some recparam ->
 417                 (match reduceaux context [] recparam with
 418                     C.MutConstruct _
 419                   | C.Appl ((C.MutConstruct _)::_) ->
 420                      let body' =
 421                       let counter = ref (List.length fl) in
 422                        List.fold_right
 423                         (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
 424                         fl
 425                         body
 426                      in
 427                       (* Possible optimization: substituting whd recparam in l*)
 428                       reduceaux context l body'
 429                   | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
 430                 )
 431              | None -> if l = [] then t' () else C.Appl ((t' ())::l)
 432            )
 433     | C.CoFix (i,fl) ->
 434        let tys =
 435         List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 436        in
 437         let t' =
 438          let fl' =
 439           List.map
 440            (function (n,ty,bo) ->
 441              (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 442            ) fl
 443          in
 444           C.CoFix (i, fl')
 445         in
 446          if l = [] then t' else C.Appl (t'::l)
 447  and reduceaux_exp_named_subst context l =
 448   List.map (function uri,t -> uri,reduceaux context [] t)
 449  in
 450   reduceaux context []
 451 ;;
 452
 453 exception WrongShape;;
 454 exception AlreadySimplified;;
 455
 456 (*CSC: I fear it is still weaker than Coq's one. For example, Coq is *)
 457 (*CSCS: able to simpl (foo (S n) (S n)) to (foo (S O) n) where       *)
 458 (*CSC:  Fix foo                                                      *)
 459 (*CSC:   {foo [n,m:nat]:nat :=                                       *)
 460 (*CSC:     Cases m of O => n | (S p) => (foo (S O) p) end            *)
 461 (*CSC:   }                                                           *)
 462 (* Takes a well-typed term and                                               *)
 463 (*  1) Performs beta-iota-zeta reduction until delta reduction is needed     *)
 464 (*  2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted  *)
 465 (*     w.r.t. zero or more variables and if the Fix can be reduced, than it  *)
 466 (*     is reduced, the delta-reduction is succesfull and the whole algorithm *)
 467 (*     is applied again to the new redex; Step 3) is applied to the result   *)
 468 (*     of the recursive simplification. Otherwise, if the Fix can not be     *)
 469 (*     reduced, than the delta-reductions fails and the delta-redex is       *)
 470 (*     not reduced. Otherwise, if the delta-residual is not the              *)
 471 (*     lambda-abstraction of a Fix, then it is reduced and the result is     *)
 472 (*     directly returned, without performing step 3).                        *)
 473 (*  3) Folds the application of the constant to the arguments that did not   *)
 474 (*     change in every iteration, i.e. to the actual arguments for the       *)
 475 (*     lambda-abstractions that precede the Fix.                             *)
 476 (*CSC: It does not perform simplification in a Case *)
 477 let simpl context =
 478  (* reduceaux is equal to the reduceaux locally defined inside *)
 479  (* reduce, but for the const case.                            *)
 480  (**** Step 1 ****)
 481  let rec reduceaux context l =
 482   let module C = Cic in
 483   let module S = CicSubstitution in
 484    function
 485       C.Rel n as t ->
 486        (match List.nth context (n-1) with
 487            Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
 488          | Some (_,C.Def bo) -> reduceaux context l (S.lift n bo)
 489          | None -> raise RelToHiddenHypothesis
 490        )
 491     | C.Var (uri,exp_named_subst) ->
 492        let exp_named_subst' =
 493         reduceaux_exp_named_subst context l exp_named_subst
 494        in
 495         (match CicEnvironment.get_obj uri with
 496             C.Constant _ -> raise ReferenceToConstant
 497           | C.CurrentProof _ -> raise ReferenceToCurrentProof
 498           | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 499           | C.Variable (_,None,_,_) ->
 500             let t' = C.Var (uri,exp_named_subst') in
 501              if l = [] then t' else C.Appl (t'::l)
 502           | C.Variable (_,Some body,_,_) ->
 503              reduceaux context l
 504               (CicSubstitution.subst_vars exp_named_subst' body)
 505         )
 506     | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
 507     | C.Sort _ as t -> t (* l should be empty *)
 508     | C.Implicit as t -> t
 509     | C.Cast (te,ty) ->
 510        C.Cast (reduceaux context l te, reduceaux context l ty)
 511     | C.Prod (name,s,t) ->
 512        assert (l = []) ;
 513        C.Prod (name,
 514         reduceaux context [] s,
 515         reduceaux ((Some (name,C.Decl s))::context) [] t)
 516     | C.Lambda (name,s,t) ->
 517        (match l with
 518            [] ->
 519             C.Lambda (name,
 520              reduceaux context [] s,
 521              reduceaux ((Some (name,C.Decl s))::context) [] t)
 522          | he::tl -> reduceaux context tl (S.subst he t)
 523            (* when name is Anonimous the substitution should be superfluous *)
 524        )
 525     | C.LetIn (n,s,t) ->
 526        reduceaux context l (S.subst (reduceaux context [] s) t)
 527     | C.Appl (he::tl) ->
 528        let tl' = List.map (reduceaux context []) tl in
 529         reduceaux context (tl'@l) he
 530     | C.Appl [] -> raise (Impossible 1)
 531     | C.Const (uri,exp_named_subst) ->
 532        let exp_named_subst' =
 533         reduceaux_exp_named_subst context l exp_named_subst
 534        in
 535         (match CicEnvironment.get_obj uri with
 536             C.Constant (_,Some body,_,_) ->
 537              begin
 538               try
 539                (**** Step 2 ****)
 540                let res,constant_args =
 541                 let rec aux rev_constant_args l =
 542                  function
 543                     C.Lambda (name,s,t) as t' ->
 544                      begin
 545                       match l with
 546                          [] -> raise WrongShape
 547                        | he::tl ->
 548                           (* when name is Anonimous the substitution should *)
 549                           (* be superfluous                                 *)
 550                           aux (he::rev_constant_args) tl (S.subst he t)
 551                      end
 552                   | C.LetIn (_,s,t) ->
 553                      aux rev_constant_args l (S.subst s t)
 554                   | C.Fix (i,fl) as t ->
 555                      let tys =
 556                       List.map (function (name,_,ty,_) ->
 557                        Some (C.Name name, C.Decl ty)) fl
 558                      in
 559                       let (_,recindex,_,body) = List.nth fl i in
 560                        let recparam =
 561                         try
 562                          List.nth l recindex
 563                         with
 564                          _ -> raise AlreadySimplified
 565                        in
 566                         (match CicReduction.whd context recparam with
 567                             C.MutConstruct _
 568                           | C.Appl ((C.MutConstruct _)::_) ->
 569                              let body' =
 570                               let counter = ref (List.length fl) in
 571                                List.fold_right
 572                                 (function _ ->
 573                                   decr counter ; S.subst (C.Fix (!counter,fl))
 574                                 ) fl body
 575                              in
 576                               (* Possible optimization: substituting whd *)
 577                               (* recparam in l                           *)
 578                               reduceaux (tys@context) l body',
 579                                List.rev rev_constant_args
 580                           | _ -> raise AlreadySimplified
 581                         )
 582                   | _ -> raise WrongShape
 583                 in
 584                  aux [] l (CicSubstitution.subst_vars exp_named_subst' body)
 585                in
 586                 (**** Step 3 ****)
 587                 let term_to_fold, delta_expanded_term_to_fold =
 588                  let body' = CicSubstitution.subst_vars exp_named_subst' body in
 589                   match constant_args with
 590                      [] -> C.Const (uri,exp_named_subst'), body'
 591                    | _ ->
 592                      C.Appl ((C.Const (uri,exp_named_subst'))::constant_args),
 593                       C.Appl (body'::constant_args)
 594                 in
 595                  let simplified_term_to_fold =
 596                   reduceaux context [] delta_expanded_term_to_fold
 597                  in
 598                   replace (=) simplified_term_to_fold term_to_fold res
 599               with
 600                  WrongShape ->
 601                   (* The constant does not unfold to a Fix lambda-abstracted  *)
 602                   (* w.r.t. zero or more variables. We just perform reduction.*)
 603                   reduceaux context l
 604                    (CicSubstitution.subst_vars exp_named_subst' body)
 605                | AlreadySimplified ->
 606                   (* If we performed delta-reduction, we would find a Fix   *)
 607                   (* not applied to a constructor. So, we refuse to perform *)
 608                   (* delta-reduction.                                       *)
 609                   let t' = C.Const (uri,exp_named_subst') in
 610                    if l = [] then t' else C.Appl (t'::l)
 611              end
 612          | C.Constant (_,None,_,_) ->
 613             let t' = C.Const (uri,exp_named_subst') in
 614              if l = [] then t' else C.Appl (t'::l)
 615          | C.Variable _ -> raise ReferenceToVariable
 616          | C.CurrentProof (_,_,body,_,_) -> reduceaux context l body
 617          | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 618        )
 619     | C.MutInd (uri,i,exp_named_subst) ->
 620        let exp_named_subst' =
 621         reduceaux_exp_named_subst context l exp_named_subst
 622        in
 623         let t' = C.MutInd (uri,i,exp_named_subst') in
 624          if l = [] then t' else C.Appl (t'::l)
 625     | C.MutConstruct (uri,i,j,exp_named_subst) ->
 626        let exp_named_subst' =
 627         reduceaux_exp_named_subst context l exp_named_subst
 628        in
 629         let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
 630          if l = [] then t' else C.Appl (t'::l)
 631     | C.MutCase (mutind,i,outtype,term,pl) ->
 632        let decofix =
 633         function
 634            C.CoFix (i,fl) as t ->
 635             let tys =
 636              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl            in
 637              let (_,_,body) = List.nth fl i in
 638               let body' =
 639                let counter = ref (List.length fl) in
 640                 List.fold_right
 641                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 642                  fl
 643                  body
 644               in
 645                reduceaux (tys@context) [] body'
 646          | C.Appl (C.CoFix (i,fl) :: tl) ->
 647             let tys =
 648              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl            in
 649              let (_,_,body) = List.nth fl i in
 650               let body' =
 651                let counter = ref (List.length fl) in
 652                 List.fold_right
 653                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 654                  fl
 655                  body
 656               in
 657                let tl' = List.map (reduceaux context []) tl in
 658                 reduceaux (tys@context) tl body'
 659          | t -> t
 660        in
 661         (match decofix (reduceaux context [] term) with
 662             C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
 663           | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
 664              let (arity, r) =
 665               match CicEnvironment.get_obj mutind with
 666                  C.InductiveDefinition (tl,ingredients,r) ->
 667                    let (_,_,arity,_) = List.nth tl i in
 668                     (arity,r)
 669                | _ -> raise WrongUriToInductiveDefinition
 670              in
 671               let ts =
 672                let rec eat_first =
 673                 function
 674                    (0,l) -> l
 675                  | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
 676                  | _ -> raise (Impossible 5)
 677                in
 678                 eat_first (r,tl)
 679               in
 680                reduceaux context (ts@l) (List.nth pl (j-1))
 681          | C.Cast _ | C.Implicit ->
 682             raise (Impossible 2) (* we don't trust our whd ;-) *)
 683          | _ ->
 684            let outtype' = reduceaux context [] outtype in
 685            let term' = reduceaux context [] term in
 686            let pl' = List.map (reduceaux context []) pl in
 687             let res =
 688              C.MutCase (mutind,i,outtype',term',pl')
 689             in
 690              if l = [] then res else C.Appl (res::l)
 691        )
 692     | C.Fix (i,fl) ->
 693        let tys =
 694         List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 695        in
 696         let t' () =
 697          let fl' =
 698           List.map
 699            (function (n,recindex,ty,bo) ->
 700              (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 701            ) fl
 702          in
 703           C.Fix (i, fl')
 704         in
 705          let (_,recindex,_,body) = List.nth fl i in
 706           let recparam =
 707            try
 708             Some (List.nth l recindex)
 709            with
 710             _ -> None
 711           in
 712            (match recparam with
 713                Some recparam ->
 714                 (match reduceaux context [] recparam with
 715                     C.MutConstruct _
 716                   | C.Appl ((C.MutConstruct _)::_) ->
 717                      let body' =
 718                       let counter = ref (List.length fl) in
 719                        List.fold_right
 720                         (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
 721                         fl
 722                         body
 723                      in
 724                       (* Possible optimization: substituting whd recparam in l*)
 725                       reduceaux context l body'
 726                   | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
 727                 )
 728              | None -> if l = [] then t' () else C.Appl ((t' ())::l)
 729            )
 730     | C.CoFix (i,fl) ->
 731        let tys =
 732         List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 733        in
 734         let t' =
 735          let fl' =
 736           List.map
 737            (function (n,ty,bo) ->
 738              (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 739            ) fl
 740          in
 741          C.CoFix (i, fl')
 742        in
 743          if l = [] then t' else C.Appl (t'::l)
 744  and reduceaux_exp_named_subst context l =
 745   List.map (function uri,t -> uri,reduceaux context [] t)
 746  in
 747   reduceaux context []
 748 ;;