X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fcic%2Fdiscrimination_tree.ml;h=faccadf654dfcf0ade39ab1b8b00945c01d19200;hb=11b2157bacf59cfc561c2ef6f92ee41ee2c1a006;hp=33ecea7cecabc2c6bbf93bb0732bd93f8cf91c79;hpb=beb4e1e9549d5b43e24907dc86c7ef899e487a3c;p=helm.git diff --git a/helm/software/components/cic/discrimination_tree.ml b/helm/software/components/cic/discrimination_tree.ml index 33ecea7ce..faccadf65 100644 --- a/helm/software/components/cic/discrimination_tree.ml +++ b/helm/software/components/cic/discrimination_tree.ml @@ -25,373 +25,210 @@ (* $Id$ *) -module DiscriminationTreeIndexing = - functor (A:Set.S) -> - struct +type 'a path_string_elem = + | Constant of 'a * int (* name, arity *) + | Bound of int * int (* rel, arity *) + | Variable (* arity is 0 *) + | Proposition (* arity is 0 *) + | Datatype (* arity is 0 *) + | Dead (* arity is 0 *) +;; + +type 'a path = ('a path_string_elem) list;; + +module type Indexable = sig + type input + type constant_name + val compare: + constant_name path_string_elem -> + constant_name path_string_elem -> int + val string_of_path : constant_name path -> string + val path_string_of : input -> constant_name path +end + +module CicIndexable : Indexable +with type input = Cic.term and type constant_name = UriManager.uri += struct + + type input = Cic.term + type constant_name = UriManager.uri + + let ppelem = function + | Constant (uri,arity) -> + "("^UriManager.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 -> "Dead" + ;; + + let path_string_of = + let rec aux arity = function + | Cic.Appl ((Cic.Meta _|Cic.Implicit _)::_) -> [Variable] + | Cic.Appl (Cic.Lambda _ :: _) -> + [Variable] (* maybe we should b-reduce *) + | Cic.Appl [] -> assert false + | Cic.Appl (hd::tl) -> + aux (List.length tl) hd @ List.flatten (List.map (aux 0) tl) + | Cic.Cast (t,_) -> aux arity t + | Cic.Lambda (_,s,t) | Cic.Prod (_,s,t) -> [Variable] + (* I think we should CicSubstitution.subst Implicit t *) + | Cic.LetIn (_,s,_,t) -> [Variable] (* z-reduce? *) + | Cic.Meta _ | Cic.Implicit _ -> assert (arity = 0); [Variable] + | Cic.Rel i -> [Bound (i, arity)] + | Cic.Sort (Cic.Prop) -> assert (arity=0); [Proposition] + | Cic.Sort _ -> assert (arity=0); [Datatype] + | Cic.Const _ | Cic.Var _ + | Cic.MutInd _ | Cic.MutConstruct _ as t -> + [Constant (CicUtil.uri_of_term t, arity)] + | Cic.MutCase _ | Cic.Fix _ | Cic.CoFix _ -> [Dead] + in + aux 0 + ;; + + let compare e1 e2 = + match e1,e2 with + | Constant (u1,a1),Constant (u2,a2) -> + let x = UriManager.compare u1 u2 in + if x = 0 then Pervasives.compare a1 a2 else x + | e1,e2 -> Pervasives.compare e1 e2 + ;; + + let string_of_path l = String.concat "." (List.map ppelem l) ;; +end + +let arity_of = function + | Constant (_,a) + | Bound (_,a) -> a + | _ -> 0 +;; - type path_string_elem = - | Function | Constant of UriManager.uri - | Bound of int | Variable | Proposition | Datatype ;; - type path_string = path_string_elem list;; +module type DiscriminationTree = + sig + type input + type data + type dataset + type constant_name + type t - (* needed by the retrieve_* functions, to know the arities of the - * "functions" *) - - let ppelem = function - | Function -> "Fun" - | Constant uri -> UriManager.name_of_uri uri - | Bound i -> string_of_int i - | Variable -> "?" - | Proposition -> "Prop" - | Datatype -> "Type" - ;; - let pppath l = String.concat "::" (List.map ppelem l) ;; - let elem_of_cic = function - | Cic.Meta _ -> Variable - | Cic.Lambda _ -> Function - | Cic.Rel i -> Bound i - | Cic.Sort (Cic.Prop) -> Proposition - | Cic.Sort _ -> Datatype - | term -> - try Constant (CicUtil.uri_of_term term) - with Invalid_argument _ -> Variable (* HACK! *) - ;; - let path_string_of_term arities = - let set_arity n = function - | Variable -> Hashtbl.replace arities Variable 0 - | e -> Hashtbl.replace arities e n - in - let rec aux = function - | Cic.Appl ((hd::tl) as l) -> -(* - if Hashtbl.mem arities (elem_of_cic hd) then - begin - let n = Hashtbl.find arities (elem_of_cic hd) in - if n <> List.length tl then - begin - prerr_endline - (String.concat " " - (List.map (fun x -> ppelem (elem_of_cic x)) l)) - end; - assert(n = List.length tl) - end; -*) - set_arity (List.length tl) (elem_of_cic hd); -(* Hashtbl.replace arities (elem_of_cic hd) (List.length tl); *) - List.concat (List.map aux l) - | t -> [elem_of_cic t] - in - aux - ;; - let compare_elem e1 e2 = - match e1,e2 with - | Constant u1,Constant u2 -> UriManager.compare u1 u2 - | e1,e2 -> Pervasives.compare e1 e2 - ;; + val iter : t -> (constant_name path -> dataset -> unit) -> unit + + val empty : t + val index : t -> input -> data -> t + val remove_index : t -> input -> data -> t + val in_index : t -> input -> (data -> bool) -> bool + val retrieve_generalizations : t -> input -> dataset + val retrieve_unifiables : t -> input -> dataset + end + +module Make (I:Indexable) (A:Set.S) : DiscriminationTree +with type constant_name = I.constant_name and type input = I.input +and type data = A.elt and type dataset = A.t = + + struct module OrderedPathStringElement = struct - type t = path_string_elem - let compare = compare_elem + type t = I.constant_name path_string_elem + let compare = I.compare end + type constant_name = I.constant_name + type data = A.elt + type dataset = A.t + type input = I.input + module PSMap = Map.Make(OrderedPathStringElement);; type key = PSMap.key module DiscriminationTree = Trie.Make(PSMap);; - type t = A.t DiscriminationTree.t * (path_string_elem, int) Hashtbl.t - let empty = DiscriminationTree.empty, Hashtbl.create 11;; - -(* - module OrderedPosEquality = struct - type t = Utils.pos * Inference.equality - let compare = Pervasives.compare - end + type t = A.t DiscriminationTree.t - module PosEqSet = Set.Make(OrderedPosEquality);; + let empty = DiscriminationTree.empty;; - let string_of_discrimination_tree tree = - let rec to_string level = function - | DiscriminationTree.Node (value, map) -> - let s = - match value with - | Some v -> - (String.make (2 * level) ' ') ^ - "{" ^ (String.concat "; " - (List.map - (fun (p, e) -> - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")") - (PosEqSet.elements v))) ^ "}" - | None -> "" - in - let rest = - String.concat "\n" - (PSMap.fold - (fun k v s -> - let ks = CicPp.ppterm k in - let rs = to_string (level+1) v in - ((String.make (2 * level) ' ') ^ ks ^ "\n" ^ rs)::s) - map []) - in - s ^ rest - in - to_string 0 tree - ;; -*) + let iter dt f = DiscriminationTree.iter (fun p x -> f p x) dt;; - let index (tree,arity) term info = - let ps = path_string_of_term arity term in + let index tree term info = + let ps = I.path_string_of 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 index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let psl = path_string_of_term l - and psr = path_string_of_term r in - let index pos tree ps = - let ps_set = - try DiscriminationTree.find ps tree with Not_found -> PosEqSet.empty in - let tree = - DiscriminationTree.add ps (PosEqSet.add (pos, equality) ps_set) tree in - tree + try DiscriminationTree.find ps tree with Not_found -> A.empty in - match ordering with - | Utils.Gt -> index Utils.Left tree psl - | Utils.Lt -> index Utils.Right tree psr - | _ -> - let tree = index Utils.Left tree psl in - index Utils.Right tree psr + DiscriminationTree.add ps (A.add info ps_set) tree ;; -*) - let remove_index (tree,arity) term info = - let ps = path_string_of_term arity term in + let remove_index tree term info = + let ps = I.path_string_of 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 + if A.is_empty ps_set then DiscriminationTree.remove ps tree + else DiscriminationTree.add ps ps_set tree + with Not_found -> tree ;; -(* -let remove_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let psl = path_string_of_term l - and psr = path_string_of_term r in - let remove_index pos tree ps = - try - let ps_set = - PosEqSet.remove (pos, equality) (DiscriminationTree.find ps tree) in - if PosEqSet.is_empty ps_set then - DiscriminationTree.remove ps tree - else - DiscriminationTree.add ps ps_set tree - with Not_found -> - tree - in - match ordering with - | Utils.Gt -> remove_index Utils.Left tree psl - | Utils.Lt -> remove_index Utils.Right tree psr - | _ -> - let tree = remove_index Utils.Left tree psl in - remove_index Utils.Right tree psr -;; -*) - - - let in_index (tree,arity) term test = - let ps = path_string_of_term arity term in + let in_index tree term test = + let ps = I.path_string_of term in try let ps_set = DiscriminationTree.find ps tree in A.exists test ps_set - with Not_found -> - false - ;; - -(* - let in_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let psl = path_string_of_term l - and psr = path_string_of_term r in - let meta_convertibility = Inference.meta_convertibility_eq equality in - let ok ps = - try - let set = DiscriminationTree.find ps tree in - PosEqSet.exists (fun (p, e) -> meta_convertibility e) set - with Not_found -> - false - in - (ok psl) || (ok psr) -;; -*) - - - let head_of_term = function - | Cic.Appl (hd::tl) -> hd - | term -> term + with Not_found -> false ;; - - let rec subterm_at_pos pos term = - match pos with - | [] -> term - | index::pos -> - match term with - | Cic.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 + (* You have h(f(x,g(y,z)),t) whose path_string_of_term_with_jl is + (h,2).(f,2).(x,0).(g,2).(y,0).(z,0).(t,0) and you are at f and want to + skip all its progeny, thus you want to reach t. + + You need to skip as many elements as the sum of all arieties contained + in the progeny of f. + + The input ariety is the one of f while the path is x.g....t + Should be the equivalent of after_t in the literature (handbook A.R.) + *) + let rec skip arity path = + if arity = 0 then path else match path with + | [] -> assert false + | m::tl -> skip (arity-1+arity_of m) tl ;; - - 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 rec retrieve tree term pos = - match tree with - | DiscriminationTree.Node (Some s, _) when pos = [] -> s - | DiscriminationTree.Node (_, map) -> - let res = - try - let hd_term = head_of_term (subterm_at_pos pos term) in - let n = PSMap.find (elem_of_cic 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 + (* the equivalent of skip, but on the index, thus the list of trees + that are rooted just after the term represented by the tree root + are returned (we are skipping the root) *) + let skip_root = function DiscriminationTree.Node (value, map) -> + let rec get n = function DiscriminationTree.Node (v, m) as tree -> + if n = 0 then [tree] else + PSMap.fold (fun k v res -> (get (n-1 + arity_of k) v) @ res) m [] in - retrieve tree term [] + PSMap.fold (fun k v res -> (get (arity_of k) v) @ res) map [] ;; - - 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 Hashtbl.find arities k - with Not_found -> 0 - in - (get (n-1 + a) v) @ res) m [] - in - PSMap.fold - (fun k v res -> - let arity = try Hashtbl.find arities k with Not_found -> 0 in - (get arity v) @ res) - map [] + let retrieve unif tree term = + let path = I.path_string_of term in + let rec retrieve path tree = + match tree, path with + | DiscriminationTree.Node (Some s, _), [] -> s + | DiscriminationTree.Node (None, _), [] -> A.empty + | DiscriminationTree.Node (_, map), Variable::path when unif -> + List.fold_left A.union A.empty + (List.map (retrieve path) (skip_root tree)) + | DiscriminationTree.Node (_, map), node::path -> + A.union + (if not unif && node = Variable then A.empty else + try retrieve path (PSMap.find node map) + with Not_found -> A.empty) + (try + match PSMap.find Variable map,skip (arity_of node) path with + | DiscriminationTree.Node (Some s, _), [] -> s + | n, path -> retrieve path n + with Not_found -> A.empty) + in + retrieve path tree ;; - - let retrieve_unifiables (tree,arities) term = - 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 (Cic.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 = - try - let hd_term = head_of_term subterm in - let n = PSMap.find (elem_of_cic 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 [] + let retrieve_generalizations tree term = retrieve false tree term;; + let retrieve_unifiables tree term = retrieve true tree term;; end ;;