+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-exception Meta_not_found of int
-exception Subst_not_found of int
-
-let lookup_meta index metasenv =
- try
- List.find (fun (index', _, _) -> index = index') metasenv
- with Not_found -> raise (Meta_not_found index)
-
-let lookup_subst n subst =
- try
- List.assoc n subst
- with Not_found -> raise (Subst_not_found n)
-
-let exists_meta index = List.exists (fun (index', _, _) -> (index = index'))
-
-(* clean_up_meta take a substitution, a metasenv a meta_inex and a local
-context l and clean up l with respect to the hidden hipothesis in the
-canonical context *)
-
-let clean_up_local_context subst metasenv n l =
- let cc =
- (try
- let (cc,_,_) = lookup_subst n subst in cc
- with Subst_not_found _ ->
- try
- let (_,cc,_) = lookup_meta n metasenv in cc
- with Meta_not_found _ -> assert false) in
- (try
- List.map2
- (fun t1 t2 ->
- match t1,t2 with
- None , _ -> None
- | _ , t -> t) cc l
- with
- Invalid_argument _ -> assert false)
-
-let is_closed =
- let module C = Cic in
- let rec is_closed k =
- function
- C.Rel m when m > k -> false
- | C.Rel m -> true
- | C.Meta (_,l) ->
- List.fold_left
- (fun i t -> i && (match t with None -> true | Some t -> is_closed k t)
- ) true l
- | C.Sort _ -> true
- | C.Implicit _ -> assert false
- | C.Cast (te,ty) -> is_closed k te && is_closed k ty
- | C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest
- | C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest
- | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest
- | C.Appl l ->
- List.fold_right (fun x i -> i && is_closed k x) l true
- | C.Var (_,exp_named_subst)
- | C.Const (_,exp_named_subst)
- | C.MutInd (_,_,exp_named_subst)
- | C.MutConstruct (_,_,_,exp_named_subst) ->
- List.fold_right (fun (_,x) i -> i && is_closed k x)
- exp_named_subst true
- | C.MutCase (_,_,out,te,pl) ->
- is_closed k out && is_closed k te &&
- List.fold_right (fun x i -> i && is_closed k x) pl true
- | C.Fix (_,fl) ->
- let len = List.length fl in
- let k_plus_len = k + len in
- List.fold_right
- (fun (_,_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
- ) fl true
- | C.CoFix (_,fl) ->
- let len = List.length fl in
- let k_plus_len = k + len in
- List.fold_right
- (fun (_,ty,bo) i -> i && is_closed k ty && is_closed k_plus_len bo
- ) fl true
-in
- is_closed 0
-;;
-
-let rec is_meta_closed =
- function
- Cic.Rel _ -> true
- | Cic.Meta _ -> false
- | Cic.Sort _ -> true
- | Cic.Implicit _ -> assert false
- | Cic.Cast (te,ty) -> is_meta_closed te && is_meta_closed ty
- | Cic.Prod (name,so,dest) -> is_meta_closed so && is_meta_closed dest
- | Cic.Lambda (_,so,dest) -> is_meta_closed so && is_meta_closed dest
- | Cic.LetIn (_,so,dest) -> is_meta_closed so && is_meta_closed dest
- | Cic.Appl l ->
- not (List.exists (fun x -> not (is_meta_closed x)) l)
- | Cic.Var (_,exp_named_subst)
- | Cic.Const (_,exp_named_subst)
- | Cic.MutInd (_,_,exp_named_subst)
- | Cic.MutConstruct (_,_,_,exp_named_subst) ->
- not (List.exists (fun (_,x) -> not (is_meta_closed x)) exp_named_subst)
- | Cic.MutCase (_,_,out,te,pl) ->
- is_meta_closed out && is_meta_closed te &&
- not (List.exists (fun x -> not (is_meta_closed x)) pl)
- | Cic.Fix (_,fl) ->
- not (List.exists
- (fun (_,_,ty,bo) ->
- not (is_meta_closed ty) || not (is_meta_closed bo))
- fl)
- | Cic.CoFix (_,fl) ->
- not (List.exists
- (fun (_,ty,bo) ->
- not (is_meta_closed ty) || not (is_meta_closed bo))
- fl)
-;;
-
-let xpointer_RE = Str.regexp "\\([^#]+\\)#xpointer(\\(.*\\))"
-let slash_RE = Str.regexp "/"
-
-let term_of_uri uri =
- let s = UriManager.string_of_uri uri in
- try
- (if UriManager.uri_is_con uri then
- Cic.Const (uri, [])
- else if UriManager.uri_is_var uri then
- Cic.Var (uri, [])
- else if not (Str.string_match xpointer_RE s 0) then
- raise (UriManager.IllFormedUri s)
- else
- let (baseuri,xpointer) = (Str.matched_group 1 s, Str.matched_group 2 s) in
- let baseuri = UriManager.uri_of_string baseuri in
- (match Str.split slash_RE xpointer with
- | [_; tyno] -> Cic.MutInd (baseuri, int_of_string tyno - 1, [])
- | [_; tyno; consno] ->
- Cic.MutConstruct
- (baseuri, int_of_string tyno - 1, int_of_string consno, [])
- | _ -> raise Exit))
- with
- | Exit
- | Failure _
- | Not_found -> raise (UriManager.IllFormedUri s)
-
-let uri_of_term = function
- | Cic.Const (uri, [])
- | Cic.Var (uri, []) -> uri
- | Cic.MutInd (baseuri, tyno, []) ->
- UriManager.uri_of_string
- (sprintf "%s#xpointer(1/%d)" (UriManager.string_of_uri baseuri) (tyno+1))
- | Cic.MutConstruct (baseuri, tyno, consno, []) ->
- UriManager.uri_of_string
- (sprintf "%s#xpointer(1/%d/%d)" (UriManager.string_of_uri baseuri)
- (tyno + 1) consno)
- | _ -> raise (Invalid_argument "uri_of_term")
-
-
-(*
-let pack terms =
- List.fold_right
- (fun term acc -> Cic.Prod (Cic.Anonymous, term, acc))
- terms (Cic.Sort (Cic.Type (CicUniv.fresh ())))
-
-let rec unpack = function
- | Cic.Prod (Cic.Anonymous, term, Cic.Sort (Cic.Type _)) -> [term]
- | Cic.Prod (Cic.Anonymous, term, tgt) -> term :: unpack tgt
- | _ -> assert false
-*)
-
-let rec strip_prods n = function
- | t when n = 0 -> t
- | Cic.Prod (_, _, tgt) when n > 0 -> strip_prods (n-1) tgt
- | _ -> failwith "not enough prods"
-
-let params_of_obj = function
- | Cic.Constant (_, _, _, params, _)
- | Cic.Variable (_, _, _, params, _)
- | Cic.CurrentProof (_, _, _, _, params, _)
- | Cic.InductiveDefinition (_, params, _, _) ->
- params
-
-let attributes_of_obj = function
- | Cic.Constant (_, _, _, _, attributes)
- | Cic.Variable (_, _, _, _, attributes)
- | Cic.CurrentProof (_, _, _, _, _, attributes)
- | Cic.InductiveDefinition (_, _, _, attributes) ->
- attributes
-let rec mk_rels howmany from =
- match howmany with
- | 0 -> []
- | _ -> (Cic.Rel (howmany + from)) :: (mk_rels (howmany-1) from)
-
-let id_of_annterm =
- function
- | Cic.ARel (id,_,_,_)
- | Cic.AVar (id,_,_)
- | Cic.AMeta (id,_,_)
- | Cic.ASort (id,_)
- | Cic.AImplicit (id,_)
- | Cic.ACast (id,_,_)
- | Cic.AProd (id,_,_,_)
- | Cic.ALambda (id,_,_,_)
- | Cic.ALetIn (id,_,_,_)
- | Cic.AAppl (id,_)
- | Cic.AConst (id,_,_)
- | Cic.AMutInd (id,_,_,_)
- | Cic.AMutConstruct (id,_,_,_,_)
- | Cic.AMutCase (id,_,_,_,_,_)
- | Cic.AFix (id,_,_)
- | Cic.ACoFix (id,_,_) -> id
-
-
-let rec rehash_term =
- let module C = Cic in
- let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in
- function
- | (C.Rel _) as t -> t
- | C.Var (uri,exp_named_subst) ->
- let uri' = recons uri in
- let exp_named_subst' =
- List.map
- (function (uri,t) ->(recons uri,rehash_term t))
- exp_named_subst
- in
- C.Var (uri',exp_named_subst')
- | C.Meta (i,l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (rehash_term t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort (C.Type u) ->
- CicUniv.assert_univ u;
- C.Sort (C.Type (CicUniv.recons_univ u))
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (rehash_term te, rehash_term ty)
- | C.Prod (n,s,t) -> C.Prod (n, rehash_term s, rehash_term t)
- | C.Lambda (n,s,t) -> C.Lambda (n, rehash_term s, rehash_term t)
- | C.LetIn (n,s,t) -> C.LetIn (n, rehash_term s, rehash_term t)
- | C.Appl l -> C.Appl (List.map rehash_term l)
- | C.Const (uri,exp_named_subst) ->
- let uri' = recons uri in
- let exp_named_subst' =
- List.map
- (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst
- in
- C.Const (uri',exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let uri' = recons uri in
- let exp_named_subst' =
- List.map
- (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst
- in
- C.MutInd (uri',tyno,exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let uri' = recons uri in
- let exp_named_subst' =
- List.map
- (function (uri,t) -> (recons uri,rehash_term t)) exp_named_subst
- in
- C.MutConstruct (uri',tyno,consno,exp_named_subst')
- | C.MutCase (uri,i,outty,t,pl) ->
- C.MutCase (recons uri, i, rehash_term outty, rehash_term t,
- List.map rehash_term pl)
- | C.Fix (i, fl) ->
- let liftedfl =
- List.map
- (fun (name, i, ty, bo) ->
- (name, i, rehash_term ty, rehash_term bo))
- fl
- in
- C.Fix (i, liftedfl)
- | C.CoFix (i, fl) ->
- let liftedfl =
- List.map
- (fun (name, ty, bo) -> (name, rehash_term ty, rehash_term bo))
- fl
- in
- C.CoFix (i, liftedfl)
-
-let rehash_obj =
- let module C = Cic in
- let recons uri = UriManager.uri_of_string (UriManager.string_of_uri uri) in
- function
- C.Constant (name,bo,ty,params,attrs) ->
- let bo' =
- match bo with
- None -> None
- | Some bo -> Some (rehash_term bo)
- in
- let ty' = rehash_term ty in
- let params' = List.map recons params in
- C.Constant (name, bo', ty', params',attrs)
- | C.CurrentProof (name,conjs,bo,ty,params,attrs) ->
- let conjs' =
- List.map
- (function (i,hyps,ty) ->
- (i,
- List.map (function
- None -> None
- | Some (name,C.Decl t) ->
- Some (name,C.Decl (rehash_term t))
- | Some (name,C.Def (bo,ty)) ->
- let ty' =
- match ty with
- None -> None
- | Some ty'' -> Some (rehash_term ty'')
- in
- Some (name,C.Def (rehash_term bo, ty'))) hyps,
- rehash_term ty))
- conjs
- in
- let bo' = rehash_term bo in
- let ty' = rehash_term ty in
- let params' = List.map recons params in
- C.CurrentProof (name, conjs', bo', ty', params',attrs)
- | C.Variable (name,bo,ty,params,attrs) ->
- let bo' =
- match bo with
- None -> None
- | Some bo -> Some (rehash_term bo)
- in
- let ty' = rehash_term ty in
- let params' = List.map recons params in
- C.Variable (name, bo', ty', params',attrs)
- | C.InductiveDefinition (tl,params,paramsno,attrs) ->
- let params' = List.map recons params in
- let tl' =
- List.map (function (name, inductive, ty, constructors) ->
- name,
- inductive,
- rehash_term ty,
- (List.map
- (function (name, ty) -> name, rehash_term ty)
- constructors))
- tl
- in
- C.InductiveDefinition (tl', params', paramsno, attrs)
-
projects / helm.git / blobdiff