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 *)
......@@ -1017,13 +1017,16 @@ module Rule = struct
| Command.DEL_FEAT (tar_cn,feat_name) ->
let tar_gid = node_find tar_cn in
(match G_graph.del_feat instance.Instance.graph tar_gid feat_name with
| None -> Error.run "DEL_FEAT: the feat does not exist %s" (Loc.to_string loc)
| Some new_graph ->
(
{instance with
Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.history
},
created_nodes
)
))
| Command.NEW_AFTER (created_name,base_cn) ->
let base_gid = node_find base_cn in
......@@ -1060,9 +1063,10 @@ module Rule = struct
| Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, _, _) = G_graph.shift_in loc ?domain true src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
(
{instance with
Instance.graph = G_graph.shift_in loc ?domain src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph;
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
......@@ -1071,9 +1075,10 @@ module Rule = struct
| Command.SHIFT_OUT (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, _, _) = G_graph.shift_out loc ?domain true src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
(
{instance with
Instance.graph = G_graph.shift_out loc ?domain src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph;
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
......@@ -1082,9 +1087,10 @@ module Rule = struct
| Command.SHIFT_EDGE (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, _, _) = G_graph.shift_edges loc ?domain true src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph in
(
{instance with
Instance.graph = G_graph.shift_edges loc ?domain src_gid tar_gid (test_locality matching created_nodes) label_cst instance.Instance.graph;
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.history
},
created_nodes
......@@ -1341,4 +1347,445 @@ module Rule = struct
Some (apply_rule ?domain instance first_matching_where_all_witout_are_fulfilled rule)
with Not_found -> None
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
let strict = false
let onf_find cnode ?loc (matching, created_nodes) =
match cnode with
| Command.Pat pid ->
(try Pid_map.find pid matching.n_match
with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
| Command.New name ->
(try List.assoc name created_nodes
with Not_found -> Error.run ?loc "Identifier '%s' not found" name)
(* ---------------------------------------------------------------------- *)
(** [onf_apply_command eff ?domain command graph matching created_nodes]
returns [(new_graph, new_created_nodes, new_eff)] *)
let onf_apply_command eff ?domain (command,loc) graph matching created_nodes =
let node_find cnode = onf_find ~loc cnode (matching, created_nodes) in
match command with
| Command.ADD_EDGE (src_cn,tar_cn,edge) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
begin
match G_graph.add_edge graph src_gid edge tar_gid with
| None when strict ->
Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
end
| Command.ADD_EDGE_EXPL (src_cn,tar_cn,edge_ident) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (_,edge,_) =
try List.assoc edge_ident matching.e_match
with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
begin
match G_graph.add_edge graph src_gid edge tar_gid with
| None when strict ->
Error.run "ADD_EDGE_EXPL: the edge '%s' already exists %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
end
| Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(match G_graph.del_edge ?domain loc graph src_gid edge tar_gid with
| None when strict -> Error.run "DEL_EDGE_EXPL: the edge '%s' does not exist %s" (G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
)
| Command.DEL_EDGE_NAME edge_ident ->
let (src_gid,edge,tar_gid) =
try List.assoc edge_ident matching.e_match
with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
(match G_graph.del_edge ?domain ~edge_ident loc graph src_gid edge tar_gid with
| None -> Error.bug "DEL_EDGE_NAME"
| Some new_graph -> (new_graph, created_nodes, true)
)
| Command.DEL_NODE node_cn ->
let node_gid = node_find node_cn in
(match G_graph.del_node graph node_gid with
| None -> Error.run "DEL_NODE: the node does not exist %s" (Loc.to_string loc)
| Some new_graph -> (new_graph, created_nodes, true)
)
| Command.UPDATE_FEAT (tar_cn,tar_feat_name, item_list) ->
let tar_gid = node_find tar_cn in
let rule_items = List.map
(function
| Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
| Command.String s -> Concat_item.String s
| Command.Param_out index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_command_value index param))
| Command.Param_in index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_param_value index param))
) item_list in
let (new_graph, new_feature_value) =
G_graph.update_feat ~loc ?domain graph tar_gid tar_feat_name rule_items in
(new_graph, created_nodes, true)
| Command.DEL_FEAT (tar_cn,feat_name) ->
let tar_gid = node_find tar_cn in
(match G_graph.del_feat graph tar_gid feat_name with
| None when strict -> Error.run "XXX"
| None -> (graph, created_nodes, eff)
| Some new_graph -> (new_graph, created_nodes, true)
)
| Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, de, ae) = G_graph.shift_in loc ?domain true src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
(new_graph, created_nodes, eff || de <> [] || ae <> [])
| Command.SHIFT_OUT (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, de, ae) = G_graph.shift_out loc ?domain true src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
(new_graph, created_nodes, eff || de <> [] || ae <> [])
| Command.SHIFT_EDGE (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (new_graph, de, ae) = G_graph.shift_edges loc ?domain true src_gid tar_gid (test_locality matching created_nodes) label_cst graph in
(new_graph, created_nodes, eff || de <> [] || ae <> [])
| Command.NEW_AFTER (created_name,base_cn) ->
let base_gid = node_find base_cn in
let (new_gid,new_graph) = G_graph.add_after base_gid graph in
(new_graph, (created_name,new_gid) :: created_nodes, true)
| Command.NEW_BEFORE (created_name,base_cn) ->
let base_gid = node_find base_cn in
let (new_gid,new_graph) = G_graph.add_before base_gid graph in
(new_graph, (created_name,new_gid) :: created_nodes, true)
| Command.NEW_NODE (created_name) ->
let (new_gid,new_graph) = G_graph.add_unordered graph in
(new_graph, (created_name,new_gid) :: created_nodes, true)
let rec onf_apply ?domain rule graph =
let (pos,negs) = rule.pattern in
(* get the list of partial matching for positive part of the pattern *)
let matching_list =
extend_matching
?domain
(pos.graph,P_graph.empty)
graph
(init rule.param pos) in
try
let (first_matching_where_all_witout_are_fulfilled,_) =
List.find
(fun (sub, already_matched_gids) ->
List.for_all
(fun neg ->
let new_partial_matching = update_partial pos.graph neg (sub, already_matched_gids) in
fulfill ?domain (pos.graph,neg.graph) graph new_partial_matching
) negs
) matching_list in
let (new_graph, created_nodes, eff) =
List.fold_left
(fun (graph, created_nodes, eff) command ->
onf_apply_command eff ?domain command graph first_matching_where_all_witout_are_fulfilled created_nodes
)
(graph, [], false)
rule.commands in
if eff
then Some new_graph
else None
with Not_found -> (* raised by List.find, no matching apply *) None
let find cnode ?loc matching =
match cnode with
| Command.Pat pid ->
(try Pid_map.find pid matching.n_match
with Not_found -> Error.bug ?loc "Inconsistent matching pid '%s' not found" (Pid.to_string pid))
| Command.New name -> Error.bug ?loc "New node must not appear HERE !" name
let gwh_apply_command ?domain (command,loc) gwh matching =
let node_find cnode = find ~loc cnode matching in
match command with
| Command.ADD_EDGE (src_cn,tar_cn,edge) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
begin
match G_graph.add_edge gwh.Graph_with_history.graph src_gid edge tar_gid with
| None when strict ->
Error.run "ADD_EDGE: the edge '%s' already exists %s"
(G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> gwh
| Some new_graph ->
{gwh with
Graph_with_history.graph = new_graph;
delta = Delta.add_edge src_gid edge tar_gid gwh.Graph_with_history.delta;
}
end
| Command.ADD_EDGE_EXPL (src_cn,tar_cn,edge_ident) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
let (_,edge,_) =
try List.assoc edge_ident matching.e_match
with Not_found -> Error.bug "The edge identifier '%s' is undefined %s" edge_ident (Loc.to_string loc) in
begin
match G_graph.add_edge gwh.Graph_with_history.graph src_gid edge tar_gid with
| None when strict ->
Error.run "ADD_EDGE_EXPL: the edge '%s' already exists %s"
(G_edge.to_string ?domain edge) (Loc.to_string loc)
| None -> gwh
| Some new_graph ->
{gwh with
Graph_with_history.graph = new_graph;
delta = Delta.add_edge src_gid edge tar_gid gwh.Graph_with_history.delta;
}
end
| Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
(match G_graph.del_edge ?domain loc gwh.Graph_with_history.graph src_gid edge tar_gid with
| None when strict ->