helm/ocaml/cic/cicUtil.ml

   1 (* Copyright (C) 2004, 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://helm.cs.unibo.it/
  24  *)
  25
  26 open Printf
  27
  28 exception Meta_not_found of int
  29 exception Subst_not_found of int
  30
  31 let lookup_meta index metasenv =
  32   try
  33     List.find (fun (index', _, _) -> index = index') metasenv
  34   with Not_found -> raise (Meta_not_found index)
  35
  36 let lookup_subst n subst =
  37   try
  38     List.assoc n subst
  39   with Not_found -> raise (Subst_not_found n)
  40
  41 let exists_meta index = List.exists (fun (index', _, _) -> (index = index'))
  42
  43 (* clean_up_meta take a substitution, a metasenv a meta_inex and a local
  44 context l and clean up l with respect to the hidden hipothesis in the
  45 canonical context *)
  46
  47 let clean_up_local_context subst metasenv n l =
  48   let cc =
  49     (try
  50        let (cc,_,_) = lookup_subst n subst in cc
  51      with Subst_not_found _ ->
  52        try
  53          let (_,cc,_) = lookup_meta n metasenv in cc
  54        with Meta_not_found _ -> assert false) in
  55   (try
  56      List.map2
  57        (fun t1 t2 ->
  58           match t1,t2 with
  59               None , _ -> None
  60             | _ , t -> t) cc l
  61    with
  62        Invalid_argument _ -> assert false)
  63
  64 let is_closed =
  65  let module C = Cic in
  66  let rec is_closed k =
  67   function
  68       C.Rel m when m > k -> false
  69     | C.Rel m -> true
  70     | C.Meta (_,l) ->
  71        List.fold_left
  72         (fun i t -> i && (match t with None -> true | Some t -> is_closed k t)
  73         ) true l
  74     | C.Sort _ -> true
  75     | C.Implicit _ -> assert false
  76     | C.Cast (te,ty) -> is_closed k te && is_closed k ty
  77     | C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest
  78     | C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest
  79     | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest
  80     | C.Appl l ->
  81        List.fold_right (fun x i -> i && is_closed k x) l true
  82     | C.Var (_,exp_named_subst)
  83     | C.Const (_,exp_named_subst)
  84     | C.MutInd (_,_,exp_named_subst)
  85     | C.MutConstruct (_,_,_,exp_named_subst) ->
  86        List.fold_right (fun (_,x) i -> i && is_closed k x)
  87         exp_named_subst true
  88     | C.MutCase (_,_,out,te,pl) ->
  89        is_closed k out && is_closed k te &&
  90         List.fold_right (fun x i -> i && is_closed k x) pl true
  91     | C.Fix (_,fl) ->
  92        let len = List.length fl in
  93         let k_plus_len = k + len in
  94          List.fold_right
  95           (fun (_,_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
  96           ) fl true
  97     | C.CoFix (_,fl) ->
  98        let len = List.length fl in
  99         let k_plus_len = k + len in
 100          List.fold_right
 101           (fun (_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
 102           ) fl true
 103 in
 104  is_closed 0
 105 ;;
 106
 107 let rec is_meta_closed =
 108   function
 109       Cic.Rel _ -> true
 110     | Cic.Meta _ -> false
 111     | Cic.Sort _ -> true
 112     | Cic.Implicit _ -> assert false
 113     | Cic.Cast (te,ty) -> is_meta_closed te && is_meta_closed ty
 114     | Cic.Prod (name,so,dest) -> is_meta_closed so && is_meta_closed dest
 115     | Cic.Lambda (_,so,dest) -> is_meta_closed so && is_meta_closed dest
 116     | Cic.LetIn (_,so,dest) -> is_meta_closed so && is_meta_closed dest
 117     | Cic.Appl l ->
 118        List.fold_right (fun x i -> i && is_meta_closed x) l true
 119     | Cic.Var (_,exp_named_subst)
 120     | Cic.Const (_,exp_named_subst)
 121     | Cic.MutInd (_,_,exp_named_subst)
 122     | Cic.MutConstruct (_,_,_,exp_named_subst) ->
 123        List.fold_right (fun (_,x) i -> i && is_meta_closed x)
 124         exp_named_subst true
 125     | Cic.MutCase (_,_,out,te,pl) ->
 126        is_meta_closed out && is_meta_closed te &&
 127         List.fold_right (fun x i -> i && is_meta_closed x) pl true
 128     | Cic.Fix (_,fl) ->
 129         List.fold_right
 130           (fun (_,_,ty,bo) i -> i && is_meta_closed ty && is_meta_closed bo
 131           ) fl true
 132     | Cic.CoFix (_,fl) ->
 133          List.fold_right
 134           (fun (_,ty,bo) i -> i && is_meta_closed ty && is_meta_closed bo
 135           ) fl true
 136 ;;
 137
 138 let xpointer_RE = Str.regexp "\\([^#]+\\)#xpointer(\\(.*\\))"
 139 let slash_RE = Str.regexp "/"
 140
 141 let term_of_uri uri =
 142   let s = UriManager.string_of_uri uri in
 143   try
 144     (if String.sub s (String.length s - 4) 4 = ".con" then
 145       Cic.Const (uri, [])
 146     else if String.sub s (String.length s - 4) 4 = ".var" then
 147       Cic.Var (uri, [])
 148     else if not (Str.string_match xpointer_RE s 0) then
 149       raise (UriManager.IllFormedUri s)
 150     else
 151       let (baseuri,xpointer) = (Str.matched_group 1 s, Str.matched_group 2 s) in
 152       let baseuri = UriManager.uri_of_string baseuri in
 153       (match Str.split slash_RE xpointer with
 154       | [_; tyno] -> Cic.MutInd (baseuri, int_of_string tyno - 1, [])
 155       | [_; tyno; consno] ->
 156           Cic.MutConstruct
 157             (baseuri, int_of_string tyno - 1, int_of_string consno, [])
 158       | _ -> raise Exit))
 159   with
 160   | Exit
 161   | Failure _
 162   | Not_found -> raise (UriManager.IllFormedUri s)
 163
 164 let uri_of_term = function
 165   | Cic.Const (uri, [])
 166   | Cic.Var (uri, []) -> uri
 167   | Cic.MutInd (baseuri, tyno, []) ->
 168      UriManager.uri_of_string
 169       (sprintf "%s#xpointer(1/%d)" (UriManager.string_of_uri baseuri) (tyno+1))
 170   | Cic.MutConstruct (baseuri, tyno, consno, []) ->
 171      UriManager.uri_of_string
 172       (sprintf "%s#xpointer(1/%d/%d)" (UriManager.string_of_uri baseuri)
 173         (tyno + 1) consno)
 174   | _ -> raise (Invalid_argument "uri_of_term")
 175
 176 let select ~term ~context =
 177   (* i is the number of binder traversed *)
 178   let rec aux i context term =
 179     match (context, term) with
 180     | Cic.Implicit (Some `Hole), t -> [i,t]
 181     | Cic.Implicit None,_ -> []
 182     | Cic.Meta (_, ctxt1), Cic.Meta (_, ctxt2) ->
 183         List.concat
 184           (List.map2
 185             (fun t1 t2 ->
 186               (match (t1, t2) with Some t1, Some t2 -> aux i t1 t2 | _ -> []))
 187             ctxt1 ctxt2)
 188     | Cic.Cast (te1, ty1), Cic.Cast (te2, ty2) -> aux i te1 te2 @ aux i ty1 ty2
 189     | Cic.Prod (_, s1, t1), Cic.Prod (_, s2, t2)
 190     | Cic.Lambda (_, s1, t1), Cic.Lambda (_, s2, t2)
 191     | Cic.LetIn (_, s1, t1), Cic.LetIn (_, s2, t2) ->
 192         aux i s1 s2 @ aux (i+1) t1 t2
 193     | Cic.Appl terms1, Cic.Appl terms2 -> auxs i terms1 terms2
 194     | Cic.Var (_, subst1), Cic.Var (_, subst2)
 195     | Cic.Const (_, subst1), Cic.Const (_, subst2)
 196     | Cic.MutInd (_, _, subst1), Cic.MutInd (_, _, subst2)
 197     | Cic.MutConstruct (_, _, _, subst1), Cic.MutConstruct (_, _, _, subst2) ->
 198         auxs i (List.map snd subst1) (List.map snd subst2)
 199     | Cic.MutCase (_, _, out1, t1, pat1), Cic.MutCase (_ , _, out2, t2, pat2) ->
 200         aux i out1 out2 @ aux i t1 t2 @ auxs i pat1 pat2
 201     | Cic.Fix (_, funs1), Cic.Fix (_, funs2) ->
 202         List.concat
 203           (List.map2
 204             (fun (_, _, ty1, bo1) (_, _, ty2, bo2) ->
 205               aux i ty1 ty2 @ aux i bo1 bo2)
 206             funs1 funs2)
 207     | Cic.CoFix (_, funs1), Cic.CoFix (_, funs2) ->
 208         List.concat
 209           (List.map2
 210             (fun (_, ty1, bo1) (_, ty2, bo2) -> aux i ty1 ty2 @ aux i bo1 bo2)
 211             funs1 funs2)
 212     | _ -> assert false
 213   and auxs i terms1 terms2 =  (* as aux for list of terms *)
 214     List.concat (List.map2 (fun t1 t2 -> aux i t1 t2) terms1 terms2)
 215   in
 216   aux 0 context term
 217
 218 let context_of ?(equality=(==)) ~term terms =
 219   let (===) x y = equality x y in
 220   let rec aux t =
 221     match t with
 222     | t when List.exists (fun t' -> t === t') terms -> Cic.Implicit (Some `Hole)
 223     | Cic.Var (uri, subst) -> Cic.Var (uri, aux_subst subst)
 224     | Cic.Meta (i, ctxt) ->
 225         let ctxt =
 226           List.map (function None -> None | Some t -> Some (aux t)) ctxt
 227         in
 228         Cic.Meta (i, ctxt)
 229     | Cic.Cast (t, ty) -> Cic.Cast (aux t, aux ty)
 230     | Cic.Prod (name, s, t) -> Cic.Prod (name, aux s, aux t)
 231     | Cic.Lambda (name, s, t) -> Cic.Lambda (name, aux s, aux t)
 232     | Cic.LetIn (name, s, t) -> Cic.LetIn (name, aux s, aux t)
 233     | Cic.Appl terms -> Cic.Appl (List.map aux terms)
 234     | Cic.Const (uri, subst) -> Cic.Const (uri, aux_subst subst)
 235     | Cic.MutInd (uri, tyno, subst) -> Cic.MutInd (uri, tyno, aux_subst subst)
 236     | Cic.MutConstruct (uri, tyno, consno, subst) ->
 237         Cic.MutConstruct (uri, tyno, consno, aux_subst subst)
 238     | Cic.MutCase (uri, tyno, outty, t, pat) ->
 239         Cic.MutCase (uri, tyno, aux outty, aux t, List.map aux pat)
 240     | Cic.Fix (funno, funs) ->
 241         let funs =
 242           List.map (fun (name, i, ty, bo) -> (name, i, aux ty, aux bo)) funs
 243         in
 244         Cic.Fix (funno, funs)
 245     | Cic.CoFix (funno, funs) ->
 246         let funs =
 247           List.map (fun (name, ty, bo) -> (name, aux ty, aux bo)) funs
 248         in
 249         Cic.CoFix (funno, funs)
 250     | Cic.Rel _
 251     | Cic.Sort _
 252     | Cic.Implicit _ -> t
 253   and aux_subst subst =
 254     List.map (fun (uri, t) -> (uri, aux t)) subst
 255   in
 256   aux term
 257
 258 (*
 259 let pack terms =
 260   List.fold_right
 261     (fun term acc -> Cic.Prod (Cic.Anonymous, term, acc))
 262     terms (Cic.Sort (Cic.Type (CicUniv.fresh ())))
 263
 264 let rec unpack = function
 265   | Cic.Prod (Cic.Anonymous, term, Cic.Sort (Cic.Type _)) -> [term]
 266   | Cic.Prod (Cic.Anonymous, term, tgt) -> term :: unpack tgt
 267   | _ -> assert false
 268 *)
 269
 270 let rec strip_prods n = function
 271   | t when n = 0 -> t
 272   | Cic.Prod (_, _, tgt) when n > 0 -> strip_prods (n-1) tgt
 273   | _ -> failwith "not enough prods"
 274
 275 let params_of_obj = function
 276   | Cic.Constant (_, _, _, params, _)
 277   | Cic.Variable (_, _, _, params, _)
 278   | Cic.CurrentProof (_, _, _, _, params, _)
 279   | Cic.InductiveDefinition (_, params, _, _) ->
 280       params
 281
 282 let attributes_of_obj = function
 283   | Cic.Constant (_, _, _, _, attributes)
 284   | Cic.Variable (_, _, _, _, attributes)
 285   | Cic.CurrentProof (_, _, _, _, _, attributes)
 286   | Cic.InductiveDefinition (_, _, _, attributes) ->
 287       attributes
 288 let rec mk_rels howmany from =
 289   match howmany with
 290   | 0 -> []
 291   | _ -> (Cic.Rel (howmany + from)) :: (mk_rels (howmany-1) from)
 292