Commit a444e011 authored by Bruno Guillaume's avatar Bruno Guillaume

new code for graph with history

parent 695c1c74
......@@ -294,6 +294,16 @@ module List_ = struct
| (k,v)::t when key>k -> (k,v) :: (sort_remove_assoc key t)
| (_,v)::t -> t
let rec sort_remove_assoc_opt key = function
| [] -> None
| (k,_)::_ when key<k -> None
| (k,v)::t when key>k ->
(match sort_remove_assoc_opt key t with
| None -> None
| Some new_t -> Some ((k,v) :: new_t)
)
| (_,v)::t (* key = k *) -> Some t
exception Usort
let rec usort_remove key = function
......
......@@ -162,6 +162,8 @@ module List_: sig
if [key] not found, the unchanged input list is returned *)
val sort_remove_assoc: 'a -> ('a * 'b) list -> ('a * 'b) list
val sort_remove_assoc_opt: 'a -> ('a * 'b) list -> ('a * 'b) list option
val foldi_left: (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a
val prev_next_iter: (?prev:'a -> ?next:'a -> 'a -> unit) -> 'a list -> unit
......
......@@ -177,6 +177,12 @@ module Feature_domain = struct
| _ -> false
) feature_domain
let is_num feature_domain feature_name =
List.exists (function
| Ast.Num fn when fn = feature_name -> true
| _ -> false
) feature_domain
let sub feature_domain name1 name2 =
match (get name1 feature_domain, get name2 feature_domain) with
| (_, Ast.Open _) -> true
......@@ -270,6 +276,10 @@ module Domain = struct
| Some (Feature feature_domain) | Some (Both (_, feature_domain)) -> Feature_domain.is_open feature_domain name
| _ -> true
let is_num ?domain name = match domain with
| Some (Feature feature_domain) | Some (Both (_, feature_domain)) -> Feature_domain.is_num feature_domain name
| _ -> false
let check_feature ?loc ?domain name value = match domain with
| Some (Feature feature_domain) | Some (Both (_, feature_domain)) -> Feature_domain.check_feature ?loc ~feature_domain name value
| _ -> ()
......
......@@ -68,9 +68,13 @@ module Domain : sig
val get_label_style: ?domain:t -> int -> Label_domain.style option
val edge_id_from_string: ?loc:Loc.t -> ?domain:t -> string -> int option
(** [is_open_feature domain feature_name] returns [true] iff no domain is set or if [feature_name] is defined to be open in the current domain. *)
val is_open_feature: ?domain: t -> feature_name -> bool
(** [is_num domain feature_name] returns [true] iff the domain is set and [feature_name] is defined to be numerical *)
val is_num: ?domain: t -> feature_name -> bool
(** [check_feature ~loc domain feature_name feature_value] fails iff a domain is set and [feature_name,feature_value] is not defined in the current domain. *)
val check_feature: ?loc:Loc.t -> ?domain: t -> feature_name -> feature_atom -> unit
......
......@@ -194,7 +194,7 @@ module G_fs = struct
in loop t
(* ---------------------------------------------------------------------- *)
let del_feat = List_.sort_remove_assoc
let del_feat = List_.sort_remove_assoc_opt
(* ---------------------------------------------------------------------- *)
let get_atom = List_.sort_assoc
......
......@@ -35,8 +35,8 @@ module G_fs: sig
val set_feat: ?loc:Loc.t -> ?domain:Domain.t -> feature_name -> string -> t -> t
(** [del_feat feature_name t] remove the feature with name [feature_name] in [t].
If [t] does not contain such a feature, [t] is returned unchanged. *)
val del_feat: string -> t -> t
If [t] does not contain such a feature, None is returned. *)
val del_feat: string -> t -> t option
val get_atom: string -> t -> value option
......
......@@ -590,7 +590,9 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
(* move out-edges (which respect cst [labels,neg]) from id_src are moved to out-edges out off node id_tar *)
let shift_out loc ?domain src_gid tar_gid is_gid_local label_cst graph =
let shift_out loc ?domain strict src_gid tar_gid is_gid_local label_cst graph =
let del_edges = ref [] and add_edges = ref [] in
let src_node = Gid_map.find src_gid graph.map in
let tar_node = Gid_map.find tar_gid graph.map in
......@@ -603,24 +605,33 @@ module G_graph = struct
if Label_cst.match_ ?domain label_cst edge && not (is_gid_local next_gid)
then
match Massoc_gid.add_opt next_gid edge acc_tar_next with
| Some new_acc_tar_next -> (Massoc_gid.remove next_gid edge acc_src_next, new_acc_tar_next)
| None -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
| None when strict -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
| None ->
del_edges := (src_gid,edge,next_gid) :: !del_edges;
(Massoc_gid.remove next_gid edge acc_src_next, acc_tar_next)
| Some new_acc_tar_next ->
del_edges := (src_gid,edge,next_gid) :: !del_edges;
add_edges := (tar_gid,edge,next_gid) :: !add_edges;
(Massoc_gid.remove next_gid edge acc_src_next, new_acc_tar_next)
else (acc_src_next,acc_tar_next)
)
(src_next, tar_next) src_next in
{ graph with map =
graph.map
let new_map = graph.map
|> (Gid_map.add src_gid (G_node.set_next new_src_next src_node))
|> (Gid_map.add tar_gid (G_node.set_next new_tar_next tar_node))
}
|> (Gid_map.add tar_gid (G_node.set_next new_tar_next tar_node)) in
( { graph with map = new_map },
!del_edges,
!add_edges
)
(* -------------------------------------------------------------------------------- *)
let shift_in loc ?domain src_gid tar_gid is_gid_local label_cst graph =
{ graph with map =
let shift_in loc ?domain strict src_gid tar_gid is_gid_local label_cst graph =
let del_edges = ref [] and add_edges = ref [] in
let new_map =
Gid_map.mapi
(fun node_id node ->
if is_gid_local node_id
if is_gid_local node_id (* shift does not move pattern edges *)
then node
else
let node_next = G_node.get_next node in
......@@ -634,8 +645,15 @@ module G_graph = struct
if Label_cst.match_ ?domain label_cst edge
then
match List_.usort_insert edge acc_node_tar_edges with
| None -> Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
| Some l -> (List_.usort_remove edge acc_node_src_edges, l)
| None when strict ->
Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
| None ->
del_edges := (node_id,edge,src_gid) :: !del_edges;
(List_.usort_remove edge acc_node_src_edges, acc_node_tar_edges)
| Some l ->
del_edges := (node_id,edge,src_gid) :: !del_edges;
add_edges := (node_id,edge,tar_gid) :: !add_edges;
(List_.usort_remove edge acc_node_src_edges, l)
else (acc_node_src_edges,acc_node_tar_edges)
)
(node_src_edges, node_tar_edges) node_src_edges in
......@@ -644,14 +662,17 @@ module G_graph = struct
|> (Massoc_gid.replace src_gid new_node_src_edges)
|> (Massoc_gid.replace tar_gid new_node_tar_edges) in
G_node.set_next new_next node
) graph.map
}
) graph.map in
( { graph with map = new_map },
!del_edges,
!add_edges
)
(* -------------------------------------------------------------------------------- *)
let shift_edges loc ?domain src_gid tar_gid is_gid_local label_cst graph =
graph
|> (shift_in loc ?domain src_gid tar_gid is_gid_local label_cst)
|> (shift_out loc ?domain src_gid tar_gid is_gid_local label_cst)
let shift_edges loc ?domain strict src_gid tar_gid is_gid_local label_cst graph =
let (g1,de1,ae1) = shift_in loc ?domain strict src_gid tar_gid is_gid_local label_cst graph in
let (g2,de2,ae2) = shift_in loc ?domain strict src_gid tar_gid is_gid_local label_cst g1 in
(g2, de1 @ de2, ae1 @ ae2)
(* -------------------------------------------------------------------------------- *)
let set_feat ?loc ?domain graph node_id feat_name new_value =
......@@ -690,8 +711,9 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
let del_feat graph node_id feat_name =
let node = Gid_map.find node_id graph.map in
let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
{ graph with map = Gid_map.add node_id (G_node.set_fs new_fs node) graph.map }
match G_fs.del_feat feat_name (G_node.get_fs node) with
| Some new_fs -> Some { graph with map = Gid_map.add node_id (G_node.set_fs new_fs node) graph.map }
| None -> None
(* -------------------------------------------------------------------------------- *)
let to_gr ?domain graph =
......@@ -921,3 +943,76 @@ module G_graph = struct
let conll = to_conll ?domain graph in
Conll.to_dot conll
end (* module G_graph *)
(* ================================================================================ *)
(* The module [Delta] defines a type for recording the effect of a set of commands on a graph *)
(* It is used a key to detect egal graphs based on rewriting history *)
module Delta = struct
type status = Add | Del
exception Inconsistent of string
(* the tree list are ordered *)
type t = {
del_nodes: Gid.t list;
edges: ((Gid.t * Label.t * Gid.t) * status) list;
feats: ((Gid.t * feature_name) * (value option)) list;
}
let empty = { del_nodes=[]; edges=[]; feats=[]; }
let del_node gid t =
match List_.usort_insert gid t.del_nodes with
| None -> raise (Inconsistent "del_node")
| Some new_del_nodes -> {
del_nodes= new_del_nodes;
edges = List.filter (fun ((g1,_,g2),_) -> g1 <> gid && g2 <> gid) t.edges;
feats = List.filter (fun ((g,_),_) -> g <> gid) t.feats;
}
let add_edge src lab tar t =
let rec loop = fun old -> match old with
| [] -> ((src,lab,tar),Add)::old
| ((s,l,t),stat)::tail when (src,lab,tar) < (s,l,t) -> ((src,lab,tar),Add)::old
| ((s,l,t),stat)::tail when (src,lab,tar) > (s,l,t) -> ((s,l,t),stat)::(loop tail)
| ((s,l,t), Add)::tail (* (src,lab,tar) = (s,l,t) *) -> raise (Inconsistent "add_edge")
| ((s,l,t), Del)::tail (* (src,lab,tar) = (s,l,t) *) -> tail in
{ t with edges = loop t.edges }
let del_edge src lab tar t =
let rec loop = fun old -> match old with
| [] -> ((src,lab,tar),Del)::old
| ((s,l,t),stat)::tail when (src,lab,tar) < (s,l,t) -> ((src,lab,tar),Del)::old
| ((s,l,t),stat)::tail when (src,lab,tar) > (s,l,t) -> ((s,l,t),stat)::(loop tail)
| ((s,l,t), Del)::tail (* (src,lab,tar) = (s,l,t) *) -> raise (Inconsistent "del_edge")
| ((s,l,t), Add)::tail (* (src,lab,tar) = (s,l,t) *) -> tail in
{ t with edges = loop t.edges }
let set_feat seed_graph gid feat_name new_val_opt t =
(* equal_orig is true iff new val is the same as the one in seed_graph *)
let equal_orig = (new_val_opt = G_fs.get_atom feat_name (G_node.get_fs (G_graph.find gid seed_graph))) in
let rec loop = fun old -> match old with
| [] when equal_orig -> []
| [] -> [(gid,feat_name), new_val_opt]
| ((g,f),_)::tail when (gid,feat_name) < (g,f) && equal_orig -> old
| ((g,f),v)::tail when (gid,feat_name) < (g,f) -> ((gid,feat_name), new_val_opt)::old
| ((g,f),v)::tail when (gid,feat_name) > (g,f) -> ((g,f),v)::(loop tail)
| ((g,f),_)::tail when (* (g,f)=(gid,feat_name) && *) equal_orig -> tail
| ((g,f),_)::tail (* when (g,f)=(gid,feat_name) *) -> ((g,f), new_val_opt) :: tail in
{ t with feats = loop t.feats }
end (* module Delta *)
module Graph_with_history = struct
type t = {
seed: G_graph.t;
delta: Delta.t;
graph: G_graph.t;
}
(* WARNING: compare is correct only on data with the same seed! *)
let compare t1 t2 = Pervasives.compare t1.delta t2.delta
end
module Graph_with_history_set = Set.Make (Graph_with_history)
......@@ -136,14 +136,50 @@ module G_graph: sig
val add_after: Gid.t -> t -> (Gid.t * t)
val add_unordered: t -> (Gid.t * t)
(** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
val shift_in: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
(** move all out-edges from id_src are moved to out-edges out off node id_tar *)
val shift_out: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
(** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
val shift_edges: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
(** shift all crown-edges ending in [src_gid] to edges ending in [tar_gid] *)
val shift_in:
Loc.t -> (* localization of the command *)
?domain:Domain.t ->
bool -> (* true iff strict rewriting *)
Gid.t -> (* [src_gid] the source gid of the "shift_in" *)
Gid.t -> (* [tar_gid] the target gid of the "shift_in" *)
(Gid.t -> bool) -> (* a locality test: true iff the node is a pattern node *)
Label_cst.t -> (* what are the constraint on edge label *)
t -> (* input graph *)
( t * (* output graph *)
(Gid.t * G_edge.t * Gid.t) list * (* list of really deleted edges *)
(Gid.t * G_edge.t * Gid.t) list (* list of really added edges *)
)
(** shift all crown-edges starting from [src_gid] to edges starting from [tar_gid] *)
val shift_out:
Loc.t -> (* localization of the command *)
?domain:Domain.t ->
bool -> (* true iff strict rewriting *)
Gid.t -> (* [src_gid] the source gid of the "shift_out" *)
Gid.t -> (* [tar_gid] the target gid of the "shift_out" *)
(Gid.t -> bool) -> (* a locality test: true iff the node is a pattern node *)
Label_cst.t -> (* what are the constraint on edge label *)
t -> (* input graph *)
( t * (* output graph *)
(Gid.t * G_edge.t * Gid.t) list * (* list of really deleted edges *)
(Gid.t * G_edge.t * Gid.t) list (* list of really added edges *)
)
(** move all incident crown-edges from/to [src_gid] are moved to incident edges on node [tar_gid] from graph *)
val shift_edges:
Loc.t -> (* localization of the command *)
?domain:Domain.t ->
bool -> (* true iff strict rewriting *)
Gid.t -> (* [src_gid] the source gid of the "shift_edges" *)
Gid.t -> (* [tar_gid] the target gid of the "shift_edges" *)
(Gid.t -> bool) -> (* a locality test: true iff the node is a pattern node *)
Label_cst.t -> (* what are the constraint on edge label *)
t -> (* input graph *)
( t * (* output graph *)
(Gid.t * G_edge.t * Gid.t) list * (* list of really deleted edges *)
(Gid.t * G_edge.t * Gid.t) list (* list of really added edges *)
)
(** [update_feat domain tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
......@@ -153,8 +189,8 @@ module G_graph: sig
val set_feat: ?loc:Loc.t -> ?domain:Domain.t -> t -> Gid.t -> string -> string -> t
(** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
If the feature is not present, [graph] is returned. *)
val del_feat: t -> Gid.t -> string -> t
If the feature is not present, None is returned. *)
val del_feat: t -> Gid.t -> string -> t option
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Output functions *)
......@@ -166,3 +202,26 @@ module G_graph: sig
val to_conll: ?domain:Domain.t -> t -> Conll.t
val to_conll_string: ?domain:Domain.t -> t -> string
end (* module G_graph *)
module Delta : sig
type t
val empty: t
val del_node: Gid.t -> t -> t
val add_edge: Gid.t -> Label.t -> Gid.t -> t -> t
val del_edge: Gid.t -> Label.t -> Gid.t -> t -> t
val set_feat: G_graph.t -> Gid.t -> feature_name -> value option -> t -> t
end
module Graph_with_history : sig
type t = {
seed: G_graph.t;
delta: Delta.t;
graph: G_graph.t;
}
val compare: t -> t -> int
end
module Graph_with_history_set : Set.S with type elt = Graph_with_history.t
......@@ -953,4 +953,4 @@ module Grs = struct
| New_ast.If (_,s1, s2) -> (loop pointed s1) || (loop pointed s2)
| New_ast.Try (s) -> loop pointed s in
loop (top grs) (Parser.strategy strat)
end
end (* module Grs *)
This diff is collapsed.
......@@ -128,5 +128,10 @@ module Rule : sig
val onf_apply: ?domain: Domain.t -> t -> G_graph.t -> G_graph.t option
val gwh_apply: ?domain: Domain.t -> t -> Graph_with_history.t -> Graph_with_history_set.t
end (* module Rule *)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment