X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fcic%2Fdiscrimination_tree.ml;h=9d691484701477b94554a3d72b4853741ec739f5;hb=041ad23b567b9844ec187ad436595868441802f4;hp=bab98921df04691b090c6e8e3020de76e5ccf5bb;hpb=55b82bd235d82ff7f0a40d980effe1efde1f5073;p=helm.git diff --git a/helm/software/components/cic/discrimination_tree.ml b/helm/software/components/cic/discrimination_tree.ml index bab98921d..9d6914847 100644 --- a/helm/software/components/cic/discrimination_tree.ml +++ b/helm/software/components/cic/discrimination_tree.ml @@ -29,29 +29,70 @@ module DiscriminationTreeIndexing = functor (A:Set.S) -> struct - type path_string_elem = Cic.term;; + type path_string_elem = + | Function | Constant of UriManager.uri + | Bound of int | Variable | Proposition | Datatype ;; type path_string = path_string_elem list;; - (* needed by the retrieve_* functions, to know the arities of the "functions" *) + (* needed by the retrieve_* functions, to know the arities of the + * "functions" *) - let arities = Hashtbl.create 11;; - - - let rec path_string_of_term = function - | Cic.Meta _ -> [Cic.Implicit None] - | Cic.Appl ((hd::tl) as l) -> - if not (Hashtbl.mem arities hd) then - Hashtbl.add arities hd (List.length tl); - List.concat (List.map path_string_of_term l) - | term -> [term] + 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 ;; - module OrderedPathStringElement = struct - type t = path_string_elem - - let compare = Pervasives.compare + type t = path_string_elem + let compare = compare_elem end module PSMap = Map.Make(OrderedPathStringElement);; @@ -60,88 +101,88 @@ module DiscriminationTreeIndexing = module DiscriminationTree = Trie.Make(PSMap);; - type t = A.t DiscriminationTree.t - let empty = DiscriminationTree.empty + 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 + type t = Utils.pos * Inference.equality + let compare = Pervasives.compare end module PosEqSet = Set.Make(OrderedPosEquality);; let string_of_discrimination_tree tree = - let rec to_string level = function - | DiscriminationTree.Node (value, map) -> + 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 -> "" + 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 []) + 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 + s ^ rest + in + to_string 0 tree ;; *) - let index tree term info = - let ps = path_string_of_term 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 + let index (tree,arity) term info = + let 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 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 - 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 + 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 + 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 ;; *) - let remove_index tree term info = - let ps = path_string_of_term 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 - else - DiscriminationTree.add ps ps_set tree - with Not_found -> - tree + let remove_index (tree,arity) term info = + let 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 remove_index tree equality = @@ -169,175 +210,194 @@ let remove_index tree equality = *) - let in_index tree term test = - let ps = path_string_of_term term in - try - let ps_set = DiscriminationTree.find ps tree in - A.exists test ps_set - with Not_found -> - false + let in_index (tree,arity) term test = + let 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 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 _, _, (_, 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 + | Cic.Appl (hd::tl) -> hd + | term -> term ;; + let rec skip_prods = function + | Cic.Prod (_,_,t) -> skip_prods t + | term -> term + ;; 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 + 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 + 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 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 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 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 (Cic.Implicit None) 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,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 = + 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 + in + retrieve tree term [] ;; - let jump_list = function - | DiscriminationTree.Node (value, map) -> - let rec get n tree = + 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 [] + | 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_unifiables tree 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 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 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 (Cic.Implicit None) 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 + 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 (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 [] + end ;;