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