X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_refiner%2FnDiscriminationTree.ml;h=bd64cfe5d5a036b2ad0e69e0356c52a2718384af;hb=c22f39a5d5afc0ef55beb221e00e2e6703b13d90;hp=c4fd43ad2a6cd163902e673951d96db473d1e4ce;hpb=348e5e6b9765c760159107a0fdb102c3eff42cd9;p=helm.git diff --git a/helm/software/components/ng_refiner/nDiscriminationTree.ml b/helm/software/components/ng_refiner/nDiscriminationTree.ml index c4fd43ad2..bd64cfe5d 100644 --- a/helm/software/components/ng_refiner/nDiscriminationTree.ml +++ b/helm/software/components/ng_refiner/nDiscriminationTree.ml @@ -1,305 +1,86 @@ -(* - ||M|| This file is part of HELM, an Hypertextual, Electronic - ||A|| Library of Mathematics, developed at the Computer Science - ||T|| Department, University of Bologna, Italy. - ||I|| - ||T|| HELM is free software; you can redistribute it and/or - ||A|| modify it under the terms of the GNU General Public License - \ / version 2 or (at your option) any later version. - \ / This software is distributed as is, NO WARRANTY. - V_______________________________________________________________ *) +(* Copyright (C) 2005, 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://cs.unibo.it/helm/. + *) (* $Id$ *) -type path_string_elem = - | Constant of NUri.uri - | Bound of int - | Variable - | Proposition - | Datatype - | Dead of NCic.term -;; +open Discrimination_tree + +module TermOT : Set.OrderedType with type t = NCic.term = struct + type t = NCic.term + let compare = Pervasives.compare +end + +module TermSet = Set.Make(TermOT) + +module NCicIndexable : Indexable +with type input = NCic.term and type constant_name = NUri.uri = struct -type path_string = path_string_elem list;; +type input = NCic.term +type constant_name = NUri.uri let ppelem = function - | Constant uri -> NUri.name_of_uri uri - | Bound i -> string_of_int i + | Constant (uri,arity) -> + "("^NUri.name_of_uri uri ^ "," ^ string_of_int arity^")" + | Bound (i,arity) -> + "("^string_of_int i ^ "," ^ string_of_int arity^")" | Variable -> "?" | Proposition -> "Prop" | Datatype -> "Type" - | Dead t -> - "DEAD("^NCicPp.ppterm ~context:[] ~subst:[] ~metasenv:[] t^")" + | Dead -> "Dead" ;; -let pp_path_string l = String.concat "::" (List.map ppelem l) ;; - -let elem_of_cic = function - | NCic.Meta _ | NCic.Implicit _ -> Variable - | NCic.Rel i -> Bound i - | NCic.Sort (NCic.Prop) -> Proposition - | NCic.Sort _ -> Datatype - | NCic.Const (NReference.Ref (u,_)) -> Constant u - | NCic.Appl _ -> assert false (* should not happen *) - | NCic.LetIn _ | NCic.Lambda _ | NCic.Prod _ | NCic.Match _ as t -> - prerr_endline - "FIXME: the discrimination tree receives an invalid term"; - Dead t -;; - -let path_string_of_term arities = - let set_arity arities k n = - (assert (k<>Variable || n=0); - match k with - | Dead _ -> arities - | _ -> - (* here we override, but partial instantiation may trick us *) - (k,n)::(List.remove_assoc k arities)) - in - let rec aux arities = function - | NCic.Appl ((hd::tl) as l) -> - let arities = - set_arity arities (elem_of_cic hd) (List.length tl) - in - List.fold_left - (fun (arities,path) t -> - let arities,tpath = aux arities t in - arities,path@tpath) - (arities,[]) l - | t -> arities, [elem_of_cic t] +let path_string_of = + let rec aux arity = function + | NCic.Appl ((NCic.Meta _|NCic.Implicit _)::_) -> [Variable] + | NCic.Appl (NCic.Lambda _ :: _) -> [Variable] (* maybe we should b-reduce *) + | NCic.Appl [] -> assert false + | NCic.Appl (hd::tl) -> + aux (List.length tl) hd @ List.flatten (List.map (aux 0) tl) + | NCic.Lambda _ | NCic.Prod _ -> [Variable] + (* I think we should CicSubstitution.subst Implicit t *) + | NCic.LetIn _ -> [Variable] (* z-reduce? *) + | NCic.Meta _ | NCic.Implicit _ -> assert (arity = 0); [Variable] + | NCic.Rel i -> [Bound (i, arity)] + | NCic.Sort (NCic.Prop) -> assert (arity=0); [Proposition] + | NCic.Sort _ -> assert (arity=0); [Datatype] + | NCic.Const (NReference.Ref (u,_)) -> [Constant (u, arity)] + | NCic.Match _ -> [Dead] in - aux arities + aux 0 ;; -let compare_elem e1 e2 = +let compare e1 e2 = match e1,e2 with - | Constant u1,Constant u2 -> NUri.compare u1 u2 + | Constant (u1,a1),Constant (u2,a2) -> + let x = NUri.compare u1 u2 in + if x = 0 then Pervasives.compare a1 a2 else x | e1,e2 -> Pervasives.compare e1 e2 ;; -let head_of_term = function - | NCic.Appl (hd::tl) -> hd - | term -> term -;; - -let rec skip_prods = function - | NCic.Prod (_,_,t) -> skip_prods t - | term -> term -;; - - -module DiscriminationTreeIndexing = - functor (A:Set.S) -> - struct - - module OrderedPathStringElement = struct - type t = path_string_elem - let compare = compare_elem - end - - module PSMap = Map.Make(OrderedPathStringElement);; - - type key = PSMap.key - - module DiscriminationTree = Trie.Make(PSMap);; +let string_of_path l = String.concat "." (List.map ppelem l) ;; - type t = A.t DiscriminationTree.t * (path_string_elem*int) list - - let empty = DiscriminationTree.empty, [] ;; - - let iter (dt, _ ) f = - DiscriminationTree.iter (fun y x -> f y x) dt - ;; - - let index (tree,arity) term info = - let arity,ps = path_string_of_term arity term in - let ps_set = - try DiscriminationTree.find ps tree - with Not_found -> A.empty in - let tree = DiscriminationTree.add ps (A.add info ps_set) tree in - tree,arity - ;; - - let remove_index (tree,arity) term info = - let arity,ps = path_string_of_term arity term in - try - let ps_set = A.remove info (DiscriminationTree.find ps tree) in - if A.is_empty ps_set then - DiscriminationTree.remove ps tree,arity - else - DiscriminationTree.add ps ps_set tree,arity - with Not_found -> - tree,arity - ;; - - let in_index (tree,arity) term test = - let arity,ps = path_string_of_term arity term in - try - let ps_set = DiscriminationTree.find ps tree in - A.exists test ps_set - with Not_found -> - false - ;; - - let rec subterm_at_pos pos term = - match pos with - | [] -> term - | index::pos -> - match term with - | NCic.Appl l -> - (try subterm_at_pos pos (List.nth l index) - with Failure _ -> raise Not_found) - | _ -> raise Not_found - ;; - - - let rec after_t pos term = - let pos' = - match pos with - | [] -> raise Not_found - | pos -> - List.fold_right - (fun i r -> if r = [] then [i+1] else i::r) pos [] - in - try - ignore(subterm_at_pos pos' term ); pos' - with Not_found -> - let pos, _ = - List.fold_right - (fun i (r, b) -> if b then (i::r, true) else (r, true)) - pos ([], false) - in - after_t pos term - ;; - - - let next_t pos term = - let t = subterm_at_pos pos term in - try - let _ = subterm_at_pos [1] t in - pos @ [1] - with Not_found -> - match pos with - | [] -> [1] - | pos -> after_t pos term - ;; - - let retrieve_generalizations (tree,arity) term = - let term = skip_prods term in - let rec retrieve tree term pos = - match tree with - | DiscriminationTree.Node (Some s, _) when pos = [] -> s - | DiscriminationTree.Node (_, map) -> - let res = - let hd_term = - elem_of_cic (head_of_term (subterm_at_pos pos term)) - in - if hd_term = Variable then A.empty else - try - let n = PSMap.find hd_term map in - match n with - | DiscriminationTree.Node (Some s, _) -> s - | DiscriminationTree.Node (None, _) -> - let newpos = - try next_t pos term - with Not_found -> [] - in - retrieve n term newpos - with Not_found -> - A.empty - in - try - let n = PSMap.find Variable map in - let newpos = try after_t pos term with Not_found -> [-1] in - if newpos = [-1] then - match n with - | DiscriminationTree.Node (Some s, _) -> A.union s res - | _ -> res - else - A.union res (retrieve n term newpos) - with Not_found -> - res - in - retrieve tree term [] - ;; - - - let jump_list arities = function - | DiscriminationTree.Node (value, map) -> - let rec get n tree = - match tree with - | DiscriminationTree.Node (v, m) -> - if n = 0 then - [tree] - else - PSMap.fold - (fun k v res -> - let a = - try List.assoc k arities - with Not_found -> 0 - in - (get (n-1 + a) v) @ res) m [] - in - PSMap.fold - (fun k v res -> - let arity = - try - List.assoc k arities - with Not_found -> 0 in - (get arity v) @ res) - map [] - ;; - - - let retrieve_unifiables (tree,arities) term = - let term = skip_prods term in - let rec retrieve tree term pos = - match tree with - | DiscriminationTree.Node (Some s, _) when pos = [] -> s - | DiscriminationTree.Node (_, map) -> - let subterm = - try Some (subterm_at_pos pos term) with Not_found -> None - in - match subterm with - | None -> A.empty - | Some (NCic.Meta _) -> - let newpos = try next_t pos term with Not_found -> [] in - let jl = jump_list arities tree in - List.fold_left - (fun r s -> A.union r s) - A.empty - (List.map (fun t -> retrieve t term newpos) jl) - | Some subterm -> - let res = - let hd_term = elem_of_cic (head_of_term subterm) in - if hd_term = Variable then - A.empty else - try - let n = PSMap.find hd_term map in - match n with - | DiscriminationTree.Node (Some s, _) -> s - | DiscriminationTree.Node (None, _) -> - retrieve n term (next_t pos term) - with Not_found -> - A.empty - in - try - let n = PSMap.find Variable map in - let newpos = - try after_t pos term - with Not_found -> [-1] - in - if newpos = [-1] then - match n with - | DiscriminationTree.Node (Some s, _) -> - A.union s res - | _ -> res - else - A.union res (retrieve n term newpos) - with Not_found -> - res - in - retrieve tree term [] - end -;; +end +module DiscriminationTree = Make(NCicIndexable)(TermSet)