From cab8b6ddde6291eb2bccad550bbd4634c00986ae Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 19 Sep 2008 09:16:21 +0000 Subject: [PATCH] better abstraction to allow 1 discrimination tree implementation for both the new and the old CIC --- .../components/cic/discrimination_tree.ml | 129 ++++++++++-------- .../components/cic/discrimination_tree.mli | 38 ++++-- .../paramodulation/equality_indexing.ml | 11 +- .../paramodulation/equality_indexing.mli | 4 +- .../tactics/paramodulation/indexing.mli | 3 +- helm/software/components/tactics/universe.ml | 2 +- 6 files changed, 117 insertions(+), 70 deletions(-) diff --git a/helm/software/components/cic/discrimination_tree.ml b/helm/software/components/cic/discrimination_tree.ml index cb3a7d745..1609fba56 100644 --- a/helm/software/components/cic/discrimination_tree.ml +++ b/helm/software/components/cic/discrimination_tree.ml @@ -25,73 +25,94 @@ (* $Id$ *) -type path_string_elem = - | Constant of UriManager.uri * int (* name, arity *) +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 = path_string_elem list;; - -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_term_with_jl = - 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_elem 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) ;; - module DiscriminationTreeIndexing = + functor (I:Indexable) -> functor (A:Set.S) -> 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 module PSMap = Map.Make(OrderedPathStringElement);; @@ -107,7 +128,7 @@ module DiscriminationTreeIndexing = let iter dt f = DiscriminationTree.iter (fun p x -> f p x) dt;; let index tree term info = - let ps = path_string_of_term_with_jl term in + let ps = I.path_string_of term in let ps_set = try DiscriminationTree.find ps tree with Not_found -> A.empty in @@ -115,7 +136,7 @@ module DiscriminationTreeIndexing = ;; let remove_index tree term info = - let ps = path_string_of_term_with_jl term in + 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 @@ -124,7 +145,7 @@ module DiscriminationTreeIndexing = ;; let in_index tree term test = - let ps = path_string_of_term_with_jl term in + let ps = I.path_string_of term in try let ps_set = DiscriminationTree.find ps tree in A.exists test ps_set @@ -159,7 +180,7 @@ module DiscriminationTreeIndexing = ;; let retrieve unif tree term = - let path = path_string_of_term_with_jl term in + let path = I.path_string_of term in let rec retrieve path tree = match tree, path with | DiscriminationTree.Node (Some s, _), [] -> s diff --git a/helm/software/components/cic/discrimination_tree.mli b/helm/software/components/cic/discrimination_tree.mli index 1b3ab8be5..ae6fe0347 100644 --- a/helm/software/components/cic/discrimination_tree.mli +++ b/helm/software/components/cic/discrimination_tree.mli @@ -23,23 +23,45 @@ * http://cs.unibo.it/helm/. *) -type path -val string_of_path : path -> string +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 module DiscriminationTreeIndexing : + functor (I: Indexable) -> functor (A : Set.S) -> sig type t - val iter : t -> (path -> A.t -> unit) -> unit + val iter : t -> (I.constant_name path -> A.t -> unit) -> unit val empty : t - val index : t -> Cic.term -> A.elt -> t - val remove_index : t -> Cic.term -> A.elt -> t - val in_index : t -> Cic.term -> (A.elt -> bool) -> bool - val retrieve_generalizations : t -> Cic.term -> A.t - val retrieve_unifiables : t -> Cic.term -> A.t + val index : t -> I.input -> A.elt -> t + val remove_index : t -> I.input -> A.elt -> t + val in_index : t -> I.input -> (A.elt -> bool) -> bool + val retrieve_generalizations : t -> I.input -> A.t + val retrieve_unifiables : t -> I.input -> A.t end diff --git a/helm/software/components/tactics/paramodulation/equality_indexing.ml b/helm/software/components/tactics/paramodulation/equality_indexing.ml index f24ff1de1..390fa1c98 100644 --- a/helm/software/components/tactics/paramodulation/equality_indexing.ml +++ b/helm/software/components/tactics/paramodulation/equality_indexing.ml @@ -28,7 +28,8 @@ module type EqualityIndex = sig module PosEqSet : Set.S with type elt = Utils.pos * Equality.equality - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + type t = + Discrimination_tree.DiscriminationTreeIndexing(Discrimination_tree.CicIndexable)(PosEqSet).t val empty : t val retrieve_generalizations : t -> Cic.term -> PosEqSet.t val retrieve_unifiables : t -> Cic.term -> PosEqSet.t @@ -36,7 +37,7 @@ module type EqualityIndex = val remove_index : t -> Equality.equality -> t val index : t -> Equality.equality -> t val in_index : t -> Equality.equality -> bool - val iter : t -> (Discrimination_tree.path -> PosEqSet.t -> unit) -> unit + val iter : t -> (Discrimination_tree.CicIndexable.constant_name Discrimination_tree.path -> PosEqSet.t -> unit) -> unit end module DT = @@ -50,7 +51,8 @@ struct module PosEqSet = Set.Make(OrderedPosEquality);; - include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) + include + Discrimination_tree.DiscriminationTreeIndexing(Discrimination_tree.CicIndexable)(PosEqSet) (* DISCRIMINATION TREES *) @@ -95,7 +97,8 @@ module PT = module PosEqSet = Set.Make(OrderedPosEquality);; - include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) + include + Discrimination_tree.DiscriminationTreeIndexing(Discrimination_tree.CicIndexable)(PosEqSet) (* DISCRIMINATION TREES *) diff --git a/helm/software/components/tactics/paramodulation/equality_indexing.mli b/helm/software/components/tactics/paramodulation/equality_indexing.mli index 31b5e26d1..4ac6d54ec 100644 --- a/helm/software/components/tactics/paramodulation/equality_indexing.mli +++ b/helm/software/components/tactics/paramodulation/equality_indexing.mli @@ -26,7 +26,7 @@ module type EqualityIndex = sig module PosEqSet : Set.S with type elt = Utils.pos * Equality.equality - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + type t = Discrimination_tree.DiscriminationTreeIndexing(Discrimination_tree.CicIndexable)(PosEqSet).t val empty : t val retrieve_generalizations : t -> Cic.term -> PosEqSet.t val retrieve_unifiables : t -> Cic.term -> PosEqSet.t @@ -34,7 +34,7 @@ module type EqualityIndex = val remove_index : t -> Equality.equality -> t val index : t -> Equality.equality -> t val in_index : t -> Equality.equality -> bool - val iter : t -> (Discrimination_tree.path -> PosEqSet.t -> unit) -> unit + val iter : t -> (Discrimination_tree.CicIndexable.constant_name Discrimination_tree.path -> PosEqSet.t -> unit) -> unit end module DT : EqualityIndex diff --git a/helm/software/components/tactics/paramodulation/indexing.mli b/helm/software/components/tactics/paramodulation/indexing.mli index bb8bbd295..9e7ba76f7 100644 --- a/helm/software/components/tactics/paramodulation/indexing.mli +++ b/helm/software/components/tactics/paramodulation/indexing.mli @@ -30,7 +30,8 @@ module Index : module PosEqSet : Set.S with type elt = Utils.pos * Equality.equality and type t = Equality_indexing.DT.PosEqSet.t - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + type t = + Discrimination_tree.DiscriminationTreeIndexing(Discrimination_tree.CicIndexable)(PosEqSet).t end val index : Index.t -> Equality.equality -> Index.t diff --git a/helm/software/components/tactics/universe.ml b/helm/software/components/tactics/universe.ml index 8fb710755..b914fab06 100644 --- a/helm/software/components/tactics/universe.ml +++ b/helm/software/components/tactics/universe.ml @@ -28,7 +28,7 @@ module Codomain = struct let compare = Pervasives.compare end module S = Set.Make(Codomain) -module TI = Discrimination_tree.DiscriminationTreeIndexing(S) +module TI = Discrimination_tree.DiscriminationTreeIndexing(Discrimination_tree.CicIndexable)(S) type universe = TI.t let empty = TI.empty -- 2.39.2