]> matita.cs.unibo.it Git - helm.git/blob - helm/ocaml/cic/cicUtil.ml
added contextual menu to act over selected terms
[helm.git] / 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        not (List.exists (fun x -> not (is_meta_closed x)) l)
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        not (List.exists (fun (_,x) -> not (is_meta_closed x)) exp_named_subst)
124     | Cic.MutCase (_,_,out,te,pl) ->
125        is_meta_closed out && is_meta_closed te &&
126         not (List.exists (fun x -> not (is_meta_closed x)) pl)
127     | Cic.Fix (_,fl) ->
128         not (List.exists 
129               (fun (_,_,ty,bo) -> 
130                   not (is_meta_closed ty) || not (is_meta_closed bo)) 
131               fl)
132     | Cic.CoFix (_,fl) ->
133         not (List.exists 
134               (fun (_,ty,bo) -> 
135                   not (is_meta_closed ty) || not (is_meta_closed bo)) 
136               fl)
137 ;;
138
139 let xpointer_RE = Str.regexp "\\([^#]+\\)#xpointer(\\(.*\\))"
140 let slash_RE = Str.regexp "/"
141
142 let term_of_uri uri =
143   let s = UriManager.string_of_uri uri in
144   try
145     (if UriManager.uri_is_con uri then
146       Cic.Const (uri, [])
147     else if UriManager.uri_is_var uri then
148       Cic.Var (uri, [])
149     else if not (Str.string_match xpointer_RE s 0) then
150       raise (UriManager.IllFormedUri s)
151     else
152       let (baseuri,xpointer) = (Str.matched_group 1 s, Str.matched_group 2 s) in
153       let baseuri = UriManager.uri_of_string baseuri in
154       (match Str.split slash_RE xpointer with
155       | [_; tyno] -> Cic.MutInd (baseuri, int_of_string tyno - 1, [])
156       | [_; tyno; consno] ->
157           Cic.MutConstruct
158             (baseuri, int_of_string tyno - 1, int_of_string consno, [])
159       | _ -> raise Exit))
160   with
161   | Exit
162   | Failure _
163   | Not_found -> raise (UriManager.IllFormedUri s)
164
165 let uri_of_term = function
166   | Cic.Const (uri, [])
167   | Cic.Var (uri, []) -> uri
168   | Cic.MutInd (baseuri, tyno, []) ->
169      UriManager.uri_of_string
170       (sprintf "%s#xpointer(1/%d)" (UriManager.string_of_uri baseuri) (tyno+1))
171   | Cic.MutConstruct (baseuri, tyno, consno, []) ->
172      UriManager.uri_of_string
173       (sprintf "%s#xpointer(1/%d/%d)" (UriManager.string_of_uri baseuri)
174         (tyno + 1) consno)
175   | _ -> raise (Invalid_argument "uri_of_term")
176
177
178 (*
179 let pack terms =
180   List.fold_right
181     (fun term acc -> Cic.Prod (Cic.Anonymous, term, acc))
182     terms (Cic.Sort (Cic.Type (CicUniv.fresh ())))
183
184 let rec unpack = function
185   | Cic.Prod (Cic.Anonymous, term, Cic.Sort (Cic.Type _)) -> [term]
186   | Cic.Prod (Cic.Anonymous, term, tgt) -> term :: unpack tgt
187   | _ -> assert false
188 *)
189
190 let rec strip_prods n = function
191   | t when n = 0 -> t
192   | Cic.Prod (_, _, tgt) when n > 0 -> strip_prods (n-1) tgt
193   | _ -> failwith "not enough prods"
194
195 let params_of_obj = function
196   | Cic.Constant (_, _, _, params, _)
197   | Cic.Variable (_, _, _, params, _)
198   | Cic.CurrentProof (_, _, _, _, params, _)
199   | Cic.InductiveDefinition (_, params, _, _) ->
200       params
201
202 let attributes_of_obj = function
203   | Cic.Constant (_, _, _, _, attributes)
204   | Cic.Variable (_, _, _, _, attributes)
205   | Cic.CurrentProof (_, _, _, _, _, attributes)
206   | Cic.InductiveDefinition (_, _, _, attributes) ->
207       attributes
208 let rec mk_rels howmany from =
209   match howmany with 
210   | 0 -> []
211   | _ -> (Cic.Rel (howmany + from)) :: (mk_rels (howmany-1) from)
212
213 let id_of_annterm =
214   function
215   | Cic.ARel (id,_,_,_)
216   | Cic.AVar (id,_,_)
217   | Cic.AMeta (id,_,_)
218   | Cic.ASort (id,_)
219   | Cic.AImplicit (id,_)
220   | Cic.ACast (id,_,_)
221   | Cic.AProd (id,_,_,_)
222   | Cic.ALambda (id,_,_,_)
223   | Cic.ALetIn (id,_,_,_)
224   | Cic.AAppl (id,_)
225   | Cic.AConst (id,_,_)
226   | Cic.AMutInd (id,_,_,_)
227   | Cic.AMutConstruct (id,_,_,_,_)
228   | Cic.AMutCase (id,_,_,_,_,_)
229   | Cic.AFix (id,_,_)
230   | Cic.ACoFix (id,_,_) -> id
231
232
233 let rec rehash_term =
234   let module C = Cic in
235   let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in
236   function
237    | (C.Rel _) as t -> t
238    | C.Var (uri,exp_named_subst) ->
239       let uri' = recons uri in
240       let exp_named_subst' =
241        List.map
242         (function (uri,t) ->(recons uri,rehash_term t)) 
243          exp_named_subst
244       in
245        C.Var (uri',exp_named_subst')
246    | C.Meta (i,l) ->
247       let l' =
248        List.map
249         (function
250             None -> None
251           | Some t -> Some (rehash_term t)
252         ) l
253       in
254        C.Meta(i,l')
255    | C.Sort (C.Type u) -> 
256        CicUniv.assert_univ u;
257        C.Sort (C.Type (CicUniv.recons_univ u))
258    | C.Sort _ as t -> t
259    | C.Implicit _ as t -> t
260    | C.Cast (te,ty) -> C.Cast (rehash_term te, rehash_term ty)
261    | C.Prod (n,s,t) -> C.Prod (n, rehash_term s, rehash_term t)
262    | C.Lambda (n,s,t) -> C.Lambda (n, rehash_term s, rehash_term t)
263    | C.LetIn (n,s,t) -> C.LetIn (n, rehash_term s, rehash_term t)
264    | C.Appl l -> C.Appl (List.map rehash_term l)
265    | C.Const (uri,exp_named_subst) ->
266       let uri' = recons uri in
267       let exp_named_subst' = 
268        List.map
269         (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst
270       in
271        C.Const (uri',exp_named_subst')
272    | C.MutInd (uri,tyno,exp_named_subst) ->
273       let uri' = recons uri in
274       let exp_named_subst' = 
275        List.map
276         (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst
277       in
278        C.MutInd (uri',tyno,exp_named_subst')
279    | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
280       let uri' = recons uri in
281       let exp_named_subst' = 
282        List.map
283         (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst
284       in
285        C.MutConstruct (uri',tyno,consno,exp_named_subst')
286    | C.MutCase (uri,i,outty,t,pl) ->
287       C.MutCase (recons uri, i, rehash_term outty, rehash_term t,
288        List.map rehash_term pl)
289    | C.Fix (i, fl) ->
290       let liftedfl =
291        List.map
292         (fun (name, i, ty, bo) ->
293           (name, i, rehash_term ty, rehash_term bo))
294          fl
295       in
296        C.Fix (i, liftedfl)
297    | C.CoFix (i, fl) ->
298       let liftedfl =
299        List.map
300         (fun (name, ty, bo) -> (name, rehash_term ty, rehash_term bo))
301          fl
302       in
303        C.CoFix (i, liftedfl)
304
305 let rehash_obj =
306  let module C = Cic in
307  let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in
308  function 
309    C.Constant (name,bo,ty,params,attrs) ->
310      let bo' =
311        match bo with
312          None -> None
313        | Some bo -> Some (rehash_term bo)
314      in
315      let ty' = rehash_term ty in
316      let params' = List.map recons params in
317      C.Constant (name, bo', ty', params',attrs)
318  | C.CurrentProof (name,conjs,bo,ty,params,attrs) ->
319      let conjs' =
320        List.map
321          (function (i,hyps,ty) ->
322            (i,
323            List.map (function
324                None -> None
325              | Some (name,C.Decl t) ->
326                  Some (name,C.Decl (rehash_term t))
327              | Some (name,C.Def (bo,ty)) ->
328                  let ty' =
329                    match ty with
330                      None -> None
331                    | Some ty'' -> Some (rehash_term ty'')
332                  in
333                  Some (name,C.Def (rehash_term bo, ty'))) hyps,
334            rehash_term ty))
335          conjs
336      in
337      let bo' = rehash_term bo in
338      let ty' = rehash_term ty in
339      let params' = List.map recons params in
340      C.CurrentProof (name, conjs', bo', ty', params',attrs)
341  | C.Variable (name,bo,ty,params,attrs) ->
342      let bo' =
343        match bo with
344          None -> None
345        | Some bo -> Some (rehash_term bo)
346      in
347      let ty' = rehash_term ty in
348      let params' = List.map recons params in
349      C.Variable (name, bo', ty', params',attrs)
350  | C.InductiveDefinition (tl,params,paramsno,attrs) ->
351      let params' = List.map recons params in
352      let tl' =
353        List.map (function (name, inductive, ty, constructors) ->
354          name,
355          inductive,
356          rehash_term ty,
357          (List.map
358            (function (name, ty) -> name, rehash_term ty)
359            constructors))
360          tl
361      in
362      C.InductiveDefinition (tl', params', paramsno, attrs)
363