helm/ocaml/tactics/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 exception WhatAndWithWhatDoNotHaveTheSameLength;;
 121
 122 (* "textual" replacement of several subterms with other ones *)
 123 let replace ~equality ~what ~with_what ~where =
 124  let module C = Cic in
 125   let find_image t =
 126    let rec find_image_aux =
 127     function
 128        [],[] -> raise Not_found
 129      | what::tl1,with_what::tl2 ->
 130         if equality what t then with_what else find_image_aux (tl1,tl2)
 131      | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
 132    in
 133     find_image_aux (what,with_what)
 134   in
 135   let rec aux t =
 136    try
 137     find_image t
 138    with Not_found ->
 139     match t with
 140        C.Rel _ -> t
 141      | C.Var (uri,exp_named_subst) ->
 142         C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 143      | C.Meta _ -> t
 144      | C.Sort _ -> t
 145      | C.Implicit _ as t -> t
 146      | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
 147      | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
 148      | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
 149      | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
 150      | C.Appl l ->
 151         (* Invariant enforced: no application of an application *)
 152         (match List.map aux l with
 153             (C.Appl l')::tl -> C.Appl (l'@tl)
 154           | l' -> C.Appl l')
 155      | C.Const (uri,exp_named_subst) ->
 156         C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 157      | C.MutInd (uri,i,exp_named_subst) ->
 158         C.MutInd
 159          (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 160      | C.MutConstruct (uri,i,j,exp_named_subst) ->
 161         C.MutConstruct
 162          (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
 163      | C.MutCase (sp,i,outt,t,pl) ->
 164         C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
 165      | C.Fix (i,fl) ->
 166         let substitutedfl =
 167          List.map
 168           (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
 169            fl
 170         in
 171          C.Fix (i, substitutedfl)
 172      | C.CoFix (i,fl) ->
 173         let substitutedfl =
 174          List.map
 175           (fun (name,ty,bo) -> (name, aux ty, aux bo))
 176            fl
 177         in
 178          C.CoFix (i, substitutedfl)
 179    in
 180     aux where
 181 ;;
 182
 183 (* replaces in a term a term with another one. *)
 184 (* Lifting are performed as usual.             *)
 185 let replace_lifting ~equality ~what ~with_what ~where =
 186  let module C = Cic in
 187  let module S = CicSubstitution in
 188   let find_image what t =
 189    let rec find_image_aux =
 190     function
 191        [],[] -> raise Not_found
 192      | what::tl1,with_what::tl2 ->
 193         if equality what t then with_what else find_image_aux (tl1,tl2)
 194      | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
 195    in
 196     find_image_aux (what,with_what)
 197   in
 198   let rec substaux k what t =
 199    try
 200     S.lift (k-1) (find_image what t)
 201    with Not_found ->
 202     match t with
 203       C.Rel n as t -> t
 204     | C.Var (uri,exp_named_subst) ->
 205        let exp_named_subst' =
 206         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 207        in
 208         C.Var (uri,exp_named_subst')
 209     | C.Meta (i, l) as t ->
 210        let l' =
 211         List.map
 212          (function
 213              None -> None
 214            | Some t -> Some (substaux k what t)
 215          ) l
 216        in
 217         C.Meta(i,l')
 218     | C.Sort _ as t -> t
 219     | C.Implicit _ as t -> t
 220     | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
 221     | C.Prod (n,s,t) ->
 222        C.Prod
 223         (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
 224     | C.Lambda (n,s,t) ->
 225        C.Lambda
 226         (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
 227     | C.LetIn (n,s,t) ->
 228        C.LetIn
 229         (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
 230     | C.Appl (he::tl) ->
 231        (* Invariant: no Appl applied to another Appl *)
 232        let tl' = List.map (substaux k what) tl in
 233         begin
 234          match substaux k what he with
 235             C.Appl l -> C.Appl (l@tl')
 236           | _ as he' -> C.Appl (he'::tl')
 237         end
 238     | C.Appl _ -> assert false
 239     | C.Const (uri,exp_named_subst) ->
 240        let exp_named_subst' =
 241         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 242        in
 243        C.Const (uri,exp_named_subst')
 244     | C.MutInd (uri,i,exp_named_subst) ->
 245        let exp_named_subst' =
 246         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 247        in
 248         C.MutInd (uri,i,exp_named_subst')
 249     | C.MutConstruct (uri,i,j,exp_named_subst) ->
 250        let exp_named_subst' =
 251         List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
 252        in
 253         C.MutConstruct (uri,i,j,exp_named_subst')
 254     | C.MutCase (sp,i,outt,t,pl) ->
 255        C.MutCase (sp,i,substaux k what outt, substaux k what t,
 256         List.map (substaux k what) pl)
 257     | C.Fix (i,fl) ->
 258        let len = List.length fl in
 259        let substitutedfl =
 260         List.map
 261          (fun (name,i,ty,bo) ->
 262            (name, i, substaux k what ty,
 263              substaux (k+len) (List.map (S.lift len) what) bo)
 264          ) fl
 265        in
 266         C.Fix (i, substitutedfl)
 267     | C.CoFix (i,fl) ->
 268        let len = List.length fl in
 269        let substitutedfl =
 270         List.map
 271          (fun (name,ty,bo) ->
 272            (name, substaux k what ty,
 273              substaux (k+len) (List.map (S.lift len) what) bo)
 274          ) fl
 275        in
 276         C.CoFix (i, substitutedfl)
 277  in
 278   substaux 1 what where
 279 ;;
 280
 281 (* replaces in a term a list of terms with other ones. *)
 282 (* Lifting are performed as usual.                     *)
 283 let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
 284  let module C = Cic in
 285  let module S = CicSubstitution in
 286   let find_image t =
 287    let rec find_image_aux =
 288     function
 289        [],[] -> raise Not_found
 290      | what::tl1,with_what::tl2 ->
 291         if equality what t then with_what else find_image_aux (tl1,tl2)
 292      | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
 293    in
 294     find_image_aux (what,with_what)
 295   in
 296   let rec substaux k t =
 297    try
 298     S.lift (k-1) (find_image t)
 299    with Not_found ->
 300     match t with
 301        C.Rel n as t ->
 302         if n < k then C.Rel n else C.Rel (n + nnn)
 303      | C.Var (uri,exp_named_subst) ->
 304         let exp_named_subst' =
 305          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
 306         in
 307          C.Var (uri,exp_named_subst')
 308      | C.Meta (i, l) as t ->
 309         let l' =
 310          List.map
 311           (function
 312               None -> None
 313             | Some t -> Some (substaux k t)
 314           ) l
 315         in
 316          C.Meta(i,l')
 317      | C.Sort _ as t -> t
 318      | C.Implicit _ as t -> t
 319      | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
 320      | C.Prod (n,s,t) ->
 321         C.Prod (n, substaux k s, substaux (k + 1) t)
 322      | C.Lambda (n,s,t) ->
 323         C.Lambda (n, substaux k s, substaux (k + 1) t)
 324      | C.LetIn (n,s,t) ->
 325         C.LetIn (n, substaux k s, substaux (k + 1) t)
 326      | C.Appl (he::tl) ->
 327         (* Invariant: no Appl applied to another Appl *)
 328         let tl' = List.map (substaux k) tl in
 329          begin
 330           match substaux k he with
 331              C.Appl l -> C.Appl (l@tl')
 332            | _ as he' -> C.Appl (he'::tl')
 333          end
 334      | C.Appl _ -> assert false
 335      | C.Const (uri,exp_named_subst) ->
 336         let exp_named_subst' =
 337          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
 338         in
 339         C.Const (uri,exp_named_subst')
 340      | C.MutInd (uri,i,exp_named_subst) ->
 341         let exp_named_subst' =
 342          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
 343         in
 344          C.MutInd (uri,i,exp_named_subst')
 345      | C.MutConstruct (uri,i,j,exp_named_subst) ->
 346         let exp_named_subst' =
 347          List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
 348         in
 349          C.MutConstruct (uri,i,j,exp_named_subst')
 350      | C.MutCase (sp,i,outt,t,pl) ->
 351         C.MutCase (sp,i,substaux k outt, substaux k t,
 352          List.map (substaux k) pl)
 353      | C.Fix (i,fl) ->
 354         let len = List.length fl in
 355         let substitutedfl =
 356          List.map
 357           (fun (name,i,ty,bo) ->
 358             (name, i, substaux k ty, substaux (k+len) bo))
 359            fl
 360         in
 361          C.Fix (i, substitutedfl)
 362      | C.CoFix (i,fl) ->
 363         let len = List.length fl in
 364         let substitutedfl =
 365          List.map
 366           (fun (name,ty,bo) ->
 367             (name, substaux k ty, substaux (k+len) bo))
 368            fl
 369         in
 370          C.CoFix (i, substitutedfl)
 371  in
 372   substaux 1 where
 373 ;;
 374
 375 (* Takes a well-typed term and fully reduces it. *)
 376 (*CSC: It does not perform reduction in a Case *)
 377 let reduce context =
 378  let rec reduceaux context l =
 379   let module C = Cic in
 380   let module S = CicSubstitution in
 381    function
 382       C.Rel n as t ->
 383        (match List.nth context (n-1) with
 384            Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
 385          | Some (_,C.Def (bo,_)) -> reduceaux context l (S.lift n bo)
 386          | None -> raise RelToHiddenHypothesis
 387        )
 388     | C.Var (uri,exp_named_subst) ->
 389        let exp_named_subst' =
 390         reduceaux_exp_named_subst context l exp_named_subst
 391        in
 392        (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 393          match o with
 394            C.Constant _ -> raise ReferenceToConstant
 395          | C.CurrentProof _ -> raise ReferenceToCurrentProof
 396          | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 397          | C.Variable (_,None,_,_,_) ->
 398             let t' = C.Var (uri,exp_named_subst') in
 399              if l = [] then t' else C.Appl (t'::l)
 400          | C.Variable (_,Some body,_,_,_) ->
 401             (reduceaux context l
 402               (CicSubstitution.subst_vars exp_named_subst' body))
 403        )
 404     | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
 405     | C.Sort _ as t -> t (* l should be empty *)
 406     | C.Implicit _ as t -> t
 407     | C.Cast (te,ty) ->
 408        C.Cast (reduceaux context l te, reduceaux context l ty)
 409     | C.Prod (name,s,t) ->
 410        assert (l = []) ;
 411        C.Prod (name,
 412         reduceaux context [] s,
 413         reduceaux ((Some (name,C.Decl s))::context) [] t)
 414     | C.Lambda (name,s,t) ->
 415        (match l with
 416            [] ->
 417             C.Lambda (name,
 418              reduceaux context [] s,
 419              reduceaux ((Some (name,C.Decl s))::context) [] t)
 420          | he::tl -> reduceaux context tl (S.subst he t)
 421            (* when name is Anonimous the substitution should be superfluous *)
 422        )
 423     | C.LetIn (n,s,t) ->
 424        reduceaux context l (S.subst (reduceaux context [] s) t)
 425     | C.Appl (he::tl) ->
 426        let tl' = List.map (reduceaux context []) tl in
 427         reduceaux context (tl'@l) he
 428     | C.Appl [] -> raise (Impossible 1)
 429     | C.Const (uri,exp_named_subst) ->
 430        let exp_named_subst' =
 431         reduceaux_exp_named_subst context l exp_named_subst
 432        in
 433         (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 434           match o with
 435             C.Constant (_,Some body,_,_,_) ->
 436              (reduceaux context l
 437                (CicSubstitution.subst_vars exp_named_subst' body))
 438           | C.Constant (_,None,_,_,_) ->
 439              let t' = C.Const (uri,exp_named_subst') in
 440               if l = [] then t' else C.Appl (t'::l)
 441           | C.Variable _ -> raise ReferenceToVariable
 442           | C.CurrentProof (_,_,body,_,_,_) ->
 443              (reduceaux context l
 444                (CicSubstitution.subst_vars exp_named_subst' body))
 445           | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 446         )
 447     | C.MutInd (uri,i,exp_named_subst) ->
 448        let exp_named_subst' =
 449         reduceaux_exp_named_subst context l exp_named_subst
 450        in
 451         let t' = C.MutInd (uri,i,exp_named_subst') in
 452          if l = [] then t' else C.Appl (t'::l)
 453     | C.MutConstruct (uri,i,j,exp_named_subst) as t ->
 454        let exp_named_subst' =
 455         reduceaux_exp_named_subst context l exp_named_subst
 456        in
 457         let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
 458          if l = [] then t' else C.Appl (t'::l)
 459     | C.MutCase (mutind,i,outtype,term,pl) ->
 460        let decofix =
 461         function
 462            C.CoFix (i,fl) as t ->
 463             let tys =
 464              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 465             in
 466              let (_,_,body) = List.nth fl i in
 467               let body' =
 468                let counter = ref (List.length fl) in
 469                 List.fold_right
 470                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 471                  fl
 472                  body
 473               in
 474                reduceaux context [] body'
 475          | C.Appl (C.CoFix (i,fl) :: tl) ->
 476             let tys =
 477              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 478             in
 479              let (_,_,body) = List.nth fl i in
 480               let body' =
 481                let counter = ref (List.length fl) in
 482                 List.fold_right
 483                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 484                  fl
 485                  body
 486               in
 487                let tl' = List.map (reduceaux context []) tl in
 488                 reduceaux context tl' body'
 489          | t -> t
 490        in
 491         (match decofix (reduceaux context [] term) with
 492             C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
 493           | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
 494              let (arity, r) =
 495                let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
 496                  match o with
 497                      C.InductiveDefinition (tl,_,r,_) ->
 498                        let (_,_,arity,_) = List.nth tl i in
 499                          (arity,r)
 500                    | _ -> raise WrongUriToInductiveDefinition
 501              in
 502               let ts =
 503                let rec eat_first =
 504                 function
 505                    (0,l) -> l
 506                  | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
 507                  | _ -> raise (Impossible 5)
 508                in
 509                 eat_first (r,tl)
 510               in
 511                reduceaux context (ts@l) (List.nth pl (j-1))
 512          | C.Cast _ | C.Implicit _ ->
 513             raise (Impossible 2) (* we don't trust our whd ;-) *)
 514          | _ ->
 515            let outtype' = reduceaux context [] outtype in
 516            let term' = reduceaux context [] term in
 517            let pl' = List.map (reduceaux context []) pl in
 518             let res =
 519              C.MutCase (mutind,i,outtype',term',pl')
 520             in
 521              if l = [] then res else C.Appl (res::l)
 522        )
 523     | C.Fix (i,fl) ->
 524        let tys =
 525         List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 526        in
 527         let t' () =
 528          let fl' =
 529           List.map
 530            (function (n,recindex,ty,bo) ->
 531              (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 532            ) fl
 533          in
 534           C.Fix (i, fl')
 535         in
 536          let (_,recindex,_,body) = List.nth fl i in
 537           let recparam =
 538            try
 539             Some (List.nth l recindex)
 540            with
 541             _ -> None
 542           in
 543            (match recparam with
 544                Some recparam ->
 545                 (match reduceaux context [] recparam with
 546                     C.MutConstruct _
 547                   | C.Appl ((C.MutConstruct _)::_) ->
 548                      let body' =
 549                       let counter = ref (List.length fl) in
 550                        List.fold_right
 551                         (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
 552                         fl
 553                         body
 554                      in
 555                       (* Possible optimization: substituting whd recparam in l*)
 556                       reduceaux context l body'
 557                   | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
 558                 )
 559              | None -> if l = [] then t' () else C.Appl ((t' ())::l)
 560            )
 561     | C.CoFix (i,fl) ->
 562        let tys =
 563         List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 564        in
 565         let t' =
 566          let fl' =
 567           List.map
 568            (function (n,ty,bo) ->
 569              (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 570            ) fl
 571          in
 572           C.CoFix (i, fl')
 573         in
 574          if l = [] then t' else C.Appl (t'::l)
 575  and reduceaux_exp_named_subst context l =
 576   List.map (function uri,t -> uri,reduceaux context [] t)
 577  in
 578   reduceaux context []
 579 ;;
 580
 581 exception WrongShape;;
 582 exception AlreadySimplified;;
 583
 584 (* Takes a well-typed term and                                               *)
 585 (*  1) Performs beta-iota-zeta reduction until delta reduction is needed     *)
 586 (*  2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted  *)
 587 (*     w.r.t. zero or more variables and if the Fix can be reductaed, than it*)
 588 (*     is reduced, the delta-reduction is succesfull and the whole algorithm *)
 589 (*     is applied again to the new redex; Step 3.1) is applied to the result *)
 590 (*     of the recursive simplification. Otherwise, if the Fix can not be     *)
 591 (*     reduced, than the delta-reductions fails and the delta-redex is       *)
 592 (*     not reduced. Otherwise, if the delta-residual is not the              *)
 593 (*     lambda-abstraction of a Fix, then it performs step 3.2).              *)
 594 (* 3.1) Folds the application of the constant to the arguments that did not  *)
 595 (*     change in every iteration, i.e. to the actual arguments for the       *)
 596 (*     lambda-abstractions that precede the Fix.                             *)
 597 (* 3.2) Computes the head beta-zeta normal form of the term. Then it tries   *)
 598 (*     reductions. If the reduction cannot be performed, it returns the      *)
 599 (*     original term (not the head beta-zeta normal form of the definiendum) *)
 600 (*CSC: It does not perform simplification in a Case *)
 601
 602 let simpl context =
 603  let mk_appl t l =
 604    if l = [] then
 605      t
 606    else
 607      match t with
 608      | Cic.Appl l' -> Cic.Appl (l'@l)
 609      | _ -> Cic.Appl (t::l)
 610  in
 611  (* reduceaux is equal to the reduceaux locally defined inside *)
 612  (* reduce, but for the const case.                            *)
 613  (**** Step 1 ****)
 614  let rec reduceaux context l =
 615   let module C = Cic in
 616   let module S = CicSubstitution in
 617    function
 618       C.Rel n as t ->
 619        (try
 620          match List.nth context (n-1) with
 621             Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
 622           | Some (_,C.Def (bo,_)) ->
 623              try_delta_expansion context l t (S.lift n bo)
 624           | None -> raise RelToHiddenHypothesis
 625         with
 626          Failure _ -> assert false)
 627     | C.Var (uri,exp_named_subst) ->
 628        let exp_named_subst' =
 629         reduceaux_exp_named_subst context l exp_named_subst
 630        in
 631         (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 632           match o with
 633             C.Constant _ -> raise ReferenceToConstant
 634           | C.CurrentProof _ -> raise ReferenceToCurrentProof
 635           | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 636           | C.Variable (_,None,_,_,_) ->
 637             let t' = C.Var (uri,exp_named_subst') in
 638              if l = [] then t' else C.Appl (t'::l)
 639           | C.Variable (_,Some body,_,_,_) ->
 640              reduceaux context l
 641               (CicSubstitution.subst_vars exp_named_subst' body)
 642         )
 643     | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
 644     | C.Sort _ as t -> t (* l should be empty *)
 645     | C.Implicit _ as t -> t
 646     | C.Cast (te,ty) ->
 647        C.Cast (reduceaux context l te, reduceaux context l ty)
 648     | C.Prod (name,s,t) ->
 649        assert (l = []) ;
 650        C.Prod (name,
 651         reduceaux context [] s,
 652         reduceaux ((Some (name,C.Decl s))::context) [] t)
 653     | C.Lambda (name,s,t) ->
 654        (match l with
 655            [] ->
 656             C.Lambda (name,
 657              reduceaux context [] s,
 658              reduceaux ((Some (name,C.Decl s))::context) [] t)
 659          | he::tl -> reduceaux context tl (S.subst he t)
 660            (* when name is Anonimous the substitution should be superfluous *)
 661        )
 662     | C.LetIn (n,s,t) ->
 663        reduceaux context l (S.subst (reduceaux context [] s) t)
 664     | C.Appl (he::tl) ->
 665        let tl' = List.map (reduceaux context []) tl in
 666         reduceaux context (tl'@l) he
 667     | C.Appl [] -> raise (Impossible 1)
 668     | C.Const (uri,exp_named_subst) ->
 669        let exp_named_subst' =
 670         reduceaux_exp_named_subst context l exp_named_subst
 671        in
 672         (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 673           match o with
 674            C.Constant (_,Some body,_,_,_) ->
 675             try_delta_expansion context l
 676              (C.Const (uri,exp_named_subst'))
 677              (CicSubstitution.subst_vars exp_named_subst' body)
 678          | C.Constant (_,None,_,_,_) ->
 679             let t' = C.Const (uri,exp_named_subst') in
 680              if l = [] then t' else C.Appl (t'::l)
 681          | C.Variable _ -> raise ReferenceToVariable
 682          | C.CurrentProof (_,_,body,_,_,_) -> reduceaux context l body
 683          | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 684        )
 685     | C.MutInd (uri,i,exp_named_subst) ->
 686        let exp_named_subst' =
 687         reduceaux_exp_named_subst context l exp_named_subst
 688        in
 689         let t' = C.MutInd (uri,i,exp_named_subst') in
 690          if l = [] then t' else C.Appl (t'::l)
 691     | C.MutConstruct (uri,i,j,exp_named_subst) ->
 692        let exp_named_subst' =
 693         reduceaux_exp_named_subst context l exp_named_subst
 694        in
 695         let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
 696          if l = [] then t' else C.Appl (t'::l)
 697     | C.MutCase (mutind,i,outtype,term,pl) ->
 698        let decofix =
 699         function
 700            C.CoFix (i,fl) as t ->
 701             let tys =
 702              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl            in
 703              let (_,_,body) = List.nth fl i in
 704               let body' =
 705                let counter = ref (List.length fl) in
 706                 List.fold_right
 707                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 708                  fl
 709                  body
 710               in
 711                reduceaux context [] body'
 712          | C.Appl (C.CoFix (i,fl) :: tl) ->
 713             let tys =
 714              List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl            in
 715              let (_,_,body) = List.nth fl i in
 716               let body' =
 717                let counter = ref (List.length fl) in
 718                 List.fold_right
 719                  (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
 720                  fl
 721                  body
 722               in
 723                let tl' = List.map (reduceaux context []) tl in
 724                 reduceaux context tl body'
 725          | t -> t
 726        in
 727         (match decofix (CicReduction.whd context term) with
 728             C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
 729           | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
 730              let (arity, r) =
 731                let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
 732                  match o with
 733                      C.InductiveDefinition (tl,ingredients,r,_) ->
 734                        let (_,_,arity,_) = List.nth tl i in
 735                          (arity,r)
 736                    | _ -> raise WrongUriToInductiveDefinition
 737              in
 738               let ts =
 739                let rec eat_first =
 740                 function
 741                    (0,l) -> l
 742                  | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
 743                  | _ -> raise (Impossible 5)
 744                in
 745                 eat_first (r,tl)
 746               in
 747                reduceaux context (ts@l) (List.nth pl (j-1))
 748          | C.Cast _ | C.Implicit _ ->
 749             raise (Impossible 2) (* we don't trust our whd ;-) *)
 750          | _ ->
 751            let outtype' = reduceaux context [] outtype in
 752            let term' = reduceaux context [] term in
 753            let pl' = List.map (reduceaux context []) pl in
 754             let res =
 755              C.MutCase (mutind,i,outtype',term',pl')
 756             in
 757              if l = [] then res else C.Appl (res::l)
 758        )
 759     | C.Fix (i,fl) ->
 760        let tys =
 761         List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 762        in
 763         let t' () =
 764          let fl' =
 765           List.map
 766            (function (n,recindex,ty,bo) ->
 767              (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 768            ) fl
 769          in
 770           C.Fix (i, fl')
 771         in
 772          let (_,recindex,_,body) = List.nth fl i in
 773           let recparam =
 774            try
 775             Some (List.nth l recindex)
 776            with
 777             _ -> None
 778           in
 779            (match recparam with
 780                Some recparam ->
 781                 (match reduceaux context [] recparam with
 782                     C.MutConstruct _
 783                   | C.Appl ((C.MutConstruct _)::_) ->
 784                      let body' =
 785                       let counter = ref (List.length fl) in
 786                        List.fold_right
 787                         (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
 788                         fl
 789                         body
 790                      in
 791                       (* Possible optimization: substituting whd recparam in l*)
 792                       reduceaux context l body'
 793                   | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
 794                 )
 795              | None -> if l = [] then t' () else C.Appl ((t' ())::l)
 796            )
 797     | C.CoFix (i,fl) ->
 798        let tys =
 799         List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
 800        in
 801         let t' =
 802          let fl' =
 803           List.map
 804            (function (n,ty,bo) ->
 805              (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
 806            ) fl
 807          in
 808          C.CoFix (i, fl')
 809        in
 810          if l = [] then t' else C.Appl (t'::l)
 811  and reduceaux_exp_named_subst context l =
 812   List.map (function uri,t -> uri,reduceaux context [] t)
 813  (**** Step 2 ****)
 814  and try_delta_expansion context l term body =
 815   let module C = Cic in
 816   let module S = CicSubstitution in
 817    try
 818     let res,constant_args =
 819      let rec aux rev_constant_args l =
 820       function
 821          C.Lambda (name,s,t) as t' ->
 822           begin
 823            match l with
 824               [] -> raise WrongShape
 825             | he::tl ->
 826                (* when name is Anonimous the substitution should *)
 827                (* be superfluous                                 *)
 828                aux (he::rev_constant_args) tl (S.subst he t)
 829           end
 830        | C.LetIn (_,s,t) ->
 831           aux rev_constant_args l (S.subst s t)
 832        | C.Fix (i,fl) as t ->
 833           let tys =
 834            List.map (function (name,_,ty,_) ->
 835             Some (C.Name name, C.Decl ty)) fl
 836           in
 837            let (_,recindex,_,body) = List.nth fl i in
 838             let recparam =
 839              try
 840               List.nth l recindex
 841              with
 842               _ -> raise AlreadySimplified
 843             in
 844              (match CicReduction.whd context recparam with
 845                  C.MutConstruct _
 846                | C.Appl ((C.MutConstruct _)::_) ->
 847                   let body' =
 848                    let counter = ref (List.length fl) in
 849                     List.fold_right
 850                      (function _ ->
 851                        decr counter ; S.subst (C.Fix (!counter,fl))
 852                      ) fl body
 853                   in
 854                    (* Possible optimization: substituting whd *)
 855                    (* recparam in l                           *)
 856                    reduceaux context l body',
 857                     List.rev rev_constant_args
 858                | _ -> raise AlreadySimplified
 859              )
 860        | _ -> raise WrongShape
 861      in
 862       aux [] l body
 863     in
 864      (**** Step 3.1 ****)
 865      let term_to_fold, delta_expanded_term_to_fold =
 866       match constant_args with
 867          [] -> term,body
 868        | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
 869      in
 870       let simplified_term_to_fold =
 871        reduceaux context [] delta_expanded_term_to_fold
 872       in
 873        replace (=) [simplified_term_to_fold] [term_to_fold] res
 874    with
 875       WrongShape ->
 876        (**** Step 3.2 ****)
 877        let rec aux l =
 878         function
 879            C.Lambda (name,s,t) ->
 880              (match l with
 881                 [] -> raise AlreadySimplified
 882               | he::tl ->
 883                  (* when name is Anonimous the substitution should *)
 884                  (* be superfluous                                 *)
 885                  aux tl (S.subst he t))
 886          | C.LetIn (_,s,t) -> aux l (S.subst s t)
 887          | t ->
 888             let simplified = reduceaux context l t in
 889             if t = simplified then
 890              raise AlreadySimplified
 891             else
 892              simplified
 893        in
 894         (try aux l body
 895          with
 896           AlreadySimplified ->
 897            if l = [] then term else C.Appl (term::l))
 898     | AlreadySimplified ->
 899        (* If we performed delta-reduction, we would find a Fix   *)
 900        (* not applied to a constructor. So, we refuse to perform *)
 901        (* delta-reduction.                                       *)
 902        if l = [] then term else C.Appl (term::l)
 903  in
 904   reduceaux context []
 905 ;;
 906
 907 let unfold ?what context where =
 908  let contextlen = List.length context in
 909  let first_is_the_expandable_head_of_second context' t1 t2 =
 910   match t1,t2 with
 911      Cic.Const (uri,_), Cic.Const (uri',_)
 912    | Cic.Var (uri,_), Cic.Var (uri',_)
 913    | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_)
 914    | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri'
 915    | Cic.Const _, _
 916    | Cic.Var _, _ -> false
 917    | Cic.Rel n, Cic.Rel m
 918    | Cic.Rel n, Cic.Appl (Cic.Rel m::_) ->
 919       n + (List.length context' - contextlen) = m
 920    | Cic.Rel _, _ -> false
 921    | _,_ ->
 922      raise
 923       (ProofEngineTypes.Fail
 924         (lazy "The term to unfold is not a constant, a variable or a bound variable "))
 925  in
 926  let appl he tl =
 927   if tl = [] then he else Cic.Appl (he::tl) in
 928  let cannot_delta_expand t =
 929   raise
 930    (ProofEngineTypes.Fail
 931      (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in
 932  let rec hd_delta_beta context tl =
 933   function
 934     Cic.Rel n as t ->
 935      (try
 936        match List.nth context (n-1) with
 937           Some (_,Cic.Decl _) -> cannot_delta_expand t
 938         | Some (_,Cic.Def (bo,_)) ->
 939            CicReduction.head_beta_reduce
 940             (appl (CicSubstitution.lift n bo) tl)
 941         | None -> raise RelToHiddenHypothesis
 942       with
 943          Failure _ -> assert false)
 944   | Cic.Const (uri,exp_named_subst) as t ->
 945      let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 946       (match o with
 947           Cic.Constant (_,Some body,_,_,_) ->
 948            CicReduction.head_beta_reduce
 949             (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
 950         | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t
 951         | Cic.Variable _ -> raise ReferenceToVariable
 952         | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
 953         | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 954       )
 955   | Cic.Var (uri,exp_named_subst) as t ->
 956      let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
 957       (match o with
 958           Cic.Constant _ -> raise ReferenceToConstant
 959         | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
 960         | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
 961         | Cic.Variable (_,Some body,_,_,_) ->
 962            CicReduction.head_beta_reduce
 963             (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
 964         | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t
 965       )
 966    | Cic.Appl [] -> assert false
 967    | Cic.Appl (he::tl) -> hd_delta_beta context tl he
 968    | t -> cannot_delta_expand t
 969  in
 970  let context_and_matched_term_list =
 971   match what with
 972      None -> [context, where]
 973    | Some what ->
 974       let res =
 975        ProofEngineHelpers.locate_in_term
 976         ~equality:first_is_the_expandable_head_of_second
 977         what ~where context
 978       in
 979        if res = [] then
 980         raise
 981          (ProofEngineTypes.Fail
 982            (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where)))
 983        else
 984         res
 985  in
 986   let reduced_terms =
 987    List.map
 988     (function (context,where) -> hd_delta_beta context [] where)
 989     context_and_matched_term_list in
 990   let whats = List.map snd context_and_matched_term_list in
 991    replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where
 992 ;;