diff --git a/src/grew_command.ml b/src/grew_command.ml
index 591820f1d92f70633665ce0db121e4cd3f08cb95..3e3aabd189a20815915580fdce061143ad2c5b15 100644
--- a/src/grew_command.ml
+++ b/src/grew_command.ml
@@ -21,12 +21,12 @@ module Command = struct
(* the command in pattern *)
type p =
| DEL_NODE of cnode
- | DEL_EDGE_EXPL of (cnode * cnode *Edge.t)
+ | DEL_EDGE_EXPL of (cnode * cnode * G_edge.t)
| DEL_EDGE_NAME of string
- | ADD_EDGE of (cnode * cnode * Edge.t)
+ | ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
- | NEW_NEIGHBOUR of (string * Edge.t * pid)
+ | NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
@@ -37,12 +37,12 @@ module Command = struct
(* a item in the command history: command applied to a graph *)
type h =
| H_DEL_NODE of gid
- | H_DEL_EDGE_EXPL of (gid * gid *Edge.t)
+ | H_DEL_EDGE_EXPL of (gid * gid *G_edge.t)
| H_DEL_EDGE_NAME of string
- | H_ADD_EDGE of (gid * gid * Edge.t)
+ | H_ADD_EDGE of (gid * gid * G_edge.t)
| H_DEL_FEAT of (gid *string)
| H_UPDATE_FEAT of (gid * string * string)
- | H_NEW_NEIGHBOUR of (string * Edge.t * gid)
+ | H_NEW_NEIGHBOUR of (string * G_edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
@@ -65,7 +65,7 @@ module Command = struct
match ast_command with
| (Ast.Del_edge_expl (i, j, lab), loc) ->
check_node loc i kni; check_node loc j kni;
- let edge = Edge.make ~locals [lab] in
+ let edge = G_edge.make ~locals lab in
((DEL_EDGE_EXPL (get_pid i, get_pid j, edge), loc), (kni, kei))
| (Ast.Del_edge_name id, loc) ->
@@ -74,7 +74,7 @@ module Command = struct
| (Ast.Add_edge (i, j, lab), loc) ->
check_node loc i kni; check_node loc j kni;
- let edge = Edge.make ~locals [lab] in
+ let edge = G_edge.make ~locals lab in
((ADD_EDGE (get_pid i, get_pid j, edge), loc), (kni, kei))
| (Ast.Shift_edge (i, j), loc) ->
@@ -97,12 +97,12 @@ module Command = struct
check_node loc ancestor kni;
if List.mem name_created kni
then Error.build ~loc "Node identifier \"%s\" is already used" name_created;
- let edge = Edge.make ~locals [label] in
+ let edge = G_edge.make ~locals label in
begin
try ((NEW_NEIGHBOUR (name_created, edge, Id.build ~loc ancestor table), loc), (name_created::kni, kei))
with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
- (Edge.to_string edge)
+ (G_edge.to_string edge)
ancestor
(Loc.to_string loc)
end
diff --git a/src/grew_command.mli b/src/grew_command.mli
index 958bdb4b14350ee8f83723ed3559c107a17ce075..4e1e07a53508d1c4a7d1e4c28f3f61d285c5c472 100644
--- a/src/grew_command.mli
+++ b/src/grew_command.mli
@@ -16,12 +16,12 @@ module Command : sig
type p =
| DEL_NODE of cnode
- | DEL_EDGE_EXPL of (cnode * cnode *Edge.t)
+ | DEL_EDGE_EXPL of (cnode * cnode *G_edge.t)
| DEL_EDGE_NAME of string
- | ADD_EDGE of (cnode * cnode * Edge.t)
+ | ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
- | NEW_NEIGHBOUR of (string * Edge.t * pid)
+ | NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
@@ -31,12 +31,12 @@ module Command : sig
type t = (p * Loc.t)
type h =
| H_DEL_NODE of gid
- | H_DEL_EDGE_EXPL of (gid * gid *Edge.t)
+ | H_DEL_EDGE_EXPL of (gid * gid *G_edge.t)
| H_DEL_EDGE_NAME of string
- | H_ADD_EDGE of (gid * gid * Edge.t)
+ | H_ADD_EDGE of (gid * gid * G_edge.t)
| H_DEL_FEAT of (gid *string)
| H_UPDATE_FEAT of (gid * string * string)
- | H_NEW_NEIGHBOUR of (string * Edge.t * gid)
+ | H_NEW_NEIGHBOUR of (string * G_edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
diff --git a/src/grew_edge.ml b/src/grew_edge.ml
index 70939c88cbcdc12bf2c66594aeb0330b1f32e3d0..4163bb111a75cf31df6ee1ef65f7edeafdefea23 100644
--- a/src/grew_edge.ml
+++ b/src/grew_edge.ml
@@ -1,8 +1,10 @@
open Log
+open Printf
open Grew_utils
open Grew_ast
+(* ================================================================================ *)
module Label = struct
type decl = string * string option
@@ -28,90 +30,78 @@ module Label = struct
let get_color l = !colors.(l)
end
+(* ================================================================================ *)
-module Edge = struct
- (* the type of underspecified labels: a positive or negative constraint on a disjunction *)
- type under_label =
- | Pos of int list
- | Neg of int list
-
+(* ================================================================================ *)
+module G_edge = struct
+ type t = Label.t
+
+ let to_string = Label.to_string
+
+ let make ?(locals=[||]) string = Label.from_string ~locals string
+
+ let build ?locals (ast_edge, loc) =
+ match ast_edge.Ast.negative, ast_edge.Ast.edge_labels with
+ | (false, [one]) -> Label.from_string ~loc ?locals one
+ | (true, _) -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
+ | (false, _) -> Error.build "Only atomic edge valus are allowed in graphs%s" (Loc.to_string loc)
+
+ let to_dot ?(deco=false) l =
+ match Label.get_color l with
+ | None -> Printf.sprintf "[label=\"%s\", color=%s]" (Label.to_string l) (if deco then "red" else "black")
+ | Some c -> Printf.sprintf "[label=\"%s\", fontcolor=%s, color=%s]" (Label.to_string l) c (if deco then "red" else "black")
+
+ let to_dep ?(deco=false) l =
+ match (deco,Label.get_color l) with
+ | (false,None) -> Printf.sprintf "{ label = \"%s\"; }" (Label.to_string l)
+ | (false,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=%s; bottom; }" (Label.to_string l) c c
+ | (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red}" (Label.to_string l)
+ | (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red; bottom; }" (Label.to_string l) c
+
+end
+(* ================================================================================ *)
+
+(* ================================================================================ *)
+module P_edge = struct
+ type u_label =
+ | Pos of Label.t list
+ | Neg of Label.t list
+
type t = {
id: string option; (* an identifier for naming under_label in patterns *)
- under_label: under_label;
+ u_label: u_label;
}
- let get_id t = t.id
-
- let all = {id=None; under_label=Neg []}
+ let all = {id=None; u_label=Neg []}
- let compare = Pervasives.compare
+ let get_id t = t.id
let make ?(id=None) ?(neg=false) ?(locals=[||]) = function
- | l when neg -> {id=id; under_label=Neg (List.sort compare (List.map (Label.from_string ~locals) l))}
- | l -> {id=id; under_label=Pos (List.sort compare (List.map (Label.from_string ~locals) l))}
+ | l when neg -> {id=id; u_label=Neg (List.sort compare (List.map (Label.from_string ~locals) l))}
+ | l -> {id=id; u_label=Pos (List.sort compare (List.map (Label.from_string ~locals) l))}
let build ?locals (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id;
- under_label =
+ u_label =
if ast_edge.Ast.negative
then Neg (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
else Pos (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
}
-
- let from_string string_label =
- match string_label with
- | s when s.[0] = '^' ->
- let s' = String.sub s 1 ((String.length s) - 1) in
- {id=None; under_label=Neg (List.map Label.from_string (Str.split (Str.regexp "|") s'))}
- | _ -> {id=None; under_label=Pos (List.map Label.from_string (Str.split (Str.regexp "|") string_label))}
-
- let build_edge line =
- try
- let _ = Str.search_forward(Str.regexp("N\\(.*\\)->")) line 0 in
- let i = int_of_string (Str.matched_group 1 line) in
- let _ = Str.search_forward(Str.regexp("->N\\(.*\\)\\[")) line 0 in
- let j = int_of_string (Str.matched_group 1 line) in
- let _ = Str.search_forward(Str.regexp("label=\"\\([\\^|a-zA-Z0-9_\\-]*\\)\"")) line 0 in
- let string_label = Str.matched_group 1 line in
- (i,j,from_string string_label)
- with Not_found | Invalid_argument _ -> failwith (Printf.sprintf "%s is not an edge declaration" line)
-
- let to_string t =
- let pref = match t.id with None -> "" | Some i -> "i:" in
- match t.under_label with
+ let to_string t =
+ let pref = match t.id with None -> "" | Some i -> sprintf "%s:" i in
+ match t.u_label with
| Pos l -> pref^(List_.to_string Label.to_string "|" l)
| Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)
- let as_label t = match t.under_label with
- | Pos [one] -> one
- | _ -> failwith (Printf.sprintf "[Edge.as_label] edge '%s\' is not a label" (to_string t))
-
- let of_label l = {id=None; under_label=Pos [l]}
-
- let to_dot ?(deco=false) x =
- let l = as_label x in
- match Label.get_color l with
- | None -> Printf.sprintf "[label=\"%s\", color=%s]" (Label.to_string l) (if deco then "red" else "black")
- | Some c -> Printf.sprintf "[label=\"%s\", fontcolor=%s, color=%s]" (Label.to_string l) c (if deco then "red" else "black")
- let to_dep ?(deco=false) x =
- let l = as_label x in
- match (deco,Label.get_color l) with
- | (false,None) -> Printf.sprintf "{ label = \"%s\"; }" (Label.to_string l)
- | (false,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=%s; bottom; }" (Label.to_string l) c c
- | (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red}" (Label.to_string l)
- | (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red; bottom; }" (Label.to_string l) c
+ let compatible t g_edge = match t.u_label with
+ | Pos p -> List_.sort_mem g_edge p
+ | Neg n -> not (List_.sort_mem g_edge n)
- let compatible edge1 edge2 = match (edge1.under_label,edge2.under_label) with
- | Pos l1, Pos l2 -> not (List_.sort_is_empty_inter l1 l2)
- | Pos p, Neg n | Neg n, Pos p -> not (List_.sort_include p n)
- | Neg l1, Neg l2 -> failwith "Cannot compare two negative sets"
- let is_in graph_edge list =
- List.mem (as_label graph_edge) list
type edge_matcher =
@@ -119,30 +109,30 @@ module Edge = struct
| Ok of Label.t
| Binds of string * Label.t list
- let match_ pattern_edge graph_edge =
- let graph_label = as_label graph_edge in
+ let match_ pattern_edge graph_label =
match pattern_edge with
- | {id = Some i; under_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label])
- | {id = None; under_label = Pos l} when List.mem graph_label l -> Ok graph_label
- | {id = Some i; under_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label])
- | {id = None; under_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label
+ | {id = Some i; u_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label])
+ | {id = None; u_label = Pos l} when List.mem graph_label l -> Ok graph_label
+ | {id = Some i; u_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label])
+ | {id = None; u_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label
| _ -> Fail
let match_list pattern_edge graph_edge_list =
- let graph_labels = List.map as_label graph_edge_list in
match pattern_edge with
- | {id = None; under_label = Pos l} when List.exists (fun label -> List.mem label l) graph_labels -> Ok (List.hd graph_labels)
- | {id = None; under_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_labels -> Ok (List.hd graph_labels)
- | {id = Some i; under_label = Pos l} ->
- (match List.filter (fun label -> List.mem label l) graph_labels with
+ | {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
+ Ok (List.hd graph_edge_list)
+ | {id = None; u_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_edge_list ->
+ Ok (List.hd graph_edge_list)
+ | {id = Some i; u_label = Pos l} ->
+ (match List.filter (fun label -> List.mem label l) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list))
- | {id = Some i; under_label = Neg l} ->
- (match List.filter (fun label -> not (List.mem label l)) graph_labels with
+ | {id = Some i; u_label = Neg l} ->
+ (match List.filter (fun label -> not (List.mem label l)) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list))
| _ -> Fail
-
end
+(* ================================================================================ *)
diff --git a/src/grew_edge.mli b/src/grew_edge.mli
index 2aff9345ed6c08e77f63aef6e04f38f7cc5c7293..4d05a812becb2eec338edf9143a1f9c0e828f92c 100644
--- a/src/grew_edge.mli
+++ b/src/grew_edge.mli
@@ -16,16 +16,39 @@ module Label : sig
end
-module Edge : sig
- type t
- val as_label: t -> Label.t
- val of_label: Label.t -> t
- val get_id: t -> string option
+
+(* ================================================================================ *)
+(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
+module G_edge: sig
+ type t = Label.t
+
+ val to_string:t -> string
+
+ val make: ?locals:Label.decl array -> string -> t
+
+ val build: ?locals:Label.decl array -> Ast.edge -> t
+
+ val to_dot: ?deco:bool -> t -> string
+ val to_dep: ?deco:bool -> t -> string
+
+end
+(* ================================================================================ *)
+
+
+(* ================================================================================ *)
+(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
+module P_edge: sig
+ type t
(* [all] is the joker pattern edge *)
val all: t
+ val get_id: t -> string option
+ val to_string: t -> string
+
+ val build: ?locals:Label.decl array -> Ast.edge -> t
+
val make:
?id: string option ->
?neg:bool ->
@@ -33,27 +56,17 @@ module Edge : sig
string list ->
t
- val build: ?locals:Label.decl array -> Ast.edge -> t
-
- val compare: 'a -> 'a -> int
- val build_edge: string -> int * int * t
- val to_string: t -> string
- val to_dot: ?deco:bool -> t -> string
- val to_dep: ?deco:bool -> t -> string
-
- val compatible : t -> t -> bool
-
- val is_in : t -> Label.t list -> bool
-
+ val compatible: t -> G_edge.t -> bool
type edge_matcher =
| Fail
| Ok of Label.t
| Binds of string * Label.t list
+ val match_: t -> G_edge.t -> edge_matcher
- val match_: t -> t -> edge_matcher
+ val match_list: t -> G_edge.t list -> edge_matcher
- val match_list: t -> t list -> edge_matcher
end
+(* ================================================================================ *)
diff --git a/src/grew_graph.ml b/src/grew_graph.ml
index 65f0af0b341f4749f90371b9ab003abb793573bf..e3f18e6488ce3a0bf5947f9222a925a357395677 100644
--- a/src/grew_graph.ml
+++ b/src/grew_graph.ml
@@ -9,54 +9,38 @@ open Grew_node
open Grew_command
+(* ================================================================================ *)
module Deco = struct
type t =
{ nodes: int list;
- edges: (int * Label.t * int) list;
+ edges: (int * G_edge.t * int) list;
}
let empty = {nodes=[]; edges=[]}
end
+(* ================================================================================ *)
-module Graph = struct
- type t = {
- map: Node.t IntMap.t; (* node description *)
- lub: int; (* least upper bound *)
- }
- let empty = {map = IntMap.empty; lub = 0}
+(* ================================================================================ *)
+module P_graph = struct
+ type t = P_node.t Pid_map.t
- type gid = int
-
- type concat_item =
- | Feat of (gid * string)
- | String of string
-
- let find node_id graph = IntMap.find node_id graph.map
+ let empty = Pid_map.empty
+ let find = Pid_map.find
let map_add_edge map id_src label id_tar =
let node_src =
(* Not found can be raised when adding an edge from pos to neg *)
- try IntMap.find id_src map with Not_found -> Node.empty in
- match Massoc.add id_tar label node_src.Node.next with
- | Some l -> Some (IntMap.add id_src {node_src with Node.next = l} map)
- | None -> None
-
- (* [add_edge graph id_src label id_tar] tries to add an edge grom [id_src] to [id_tar] with [label] to [graph].
- if it succeeds, [Some new_graph] is returned
- if it fails (the edge already exists), [None] is returned
- *)
- let add_edge graph id_src label id_tar =
- match map_add_edge graph.map id_src label id_tar with
- | Some new_map -> Some {graph with map = new_map}
+ try Pid_map.find id_src map with Not_found -> P_node.empty in
+ match P_node.add_edge label id_tar node_src with
| None -> None
+ | Some new_node -> Some (Pid_map.add id_src new_node map)
let build_filter ?domain table (ast_node, loc) =
let pid = Id.build ~loc ast_node.Ast.node_id table in
let fs = Feature_structure.build ?domain ast_node.Ast.fs in
(pid, fs)
-
let build ?domain ?(locals=[||]) full_node_list full_edge_list =
let (named_nodes, constraints) =
@@ -66,7 +50,7 @@ module Graph = struct
let (tail_nodes, tail_const) = loop (ast_node.Ast.node_id :: already_bound) tail in
if List.mem ast_node.Ast.node_id already_bound
then (tail_nodes, (ast_node, loc)::tail_const)
- else (Node.build ?domain (ast_node, loc) :: tail_nodes, tail_const) in
+ else (P_node.build ?domain (ast_node, loc) :: tail_nodes, tail_const) in
loop [] full_node_list in
(* let named_nodes = List.map (Node.build ?domain) full_node_list in *)
@@ -78,34 +62,33 @@ module Graph = struct
let table = Array.of_list sorted_ids in
(* the nodes, in the same order *)
- let map_without_edges = List_.foldi_left (fun i acc elt -> IntMap.add i elt acc) IntMap.empty node_list in
+ let map_without_edges = List_.foldi_left (fun i acc elt -> Pid_map.add i elt acc) Pid_map.empty node_list in
let map =
List.fold_left
(fun acc (ast_edge, loc) ->
let i1 = Id.build ~loc ast_edge.Ast.src table in
let i2 = Id.build ~loc ast_edge.Ast.tar table in
- let edge = Edge.build ~locals (ast_edge, loc) in
+ let edge = P_edge.build ~locals (ast_edge, loc) in
(match map_add_edge acc i1 edge i2 with
| Some g -> g
| None -> Log.fcritical "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
- (Edge.to_string edge)
+ (P_edge.to_string edge)
(Loc.to_string loc)
)
) map_without_edges full_edge_list in
-
- ({map=map;lub=Array.length table}, table, List.map (build_filter ?domain table) constraints)
-
+ (map, table, List.map (build_filter ?domain table) constraints)
+
(* a type for extension of graph: a former graph exists:
in grew the former is a positive pattern and an extension is a "without" *)
- type extention = {
- ext_map: Node.t IntMap.t; (* node description for new nodes and for edge "Old -> New" *)
- old_map: Node.t IntMap.t; (* a partial map for new constraints on old nodes "Old [...]" *)
+ type extension = {
+ ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New" *)
+ old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
- let build_extention ?domain ?(locals=[||]) old_table full_node_list full_edge_list =
+ let build_extension ?domain ?(locals=[||]) old_table full_node_list full_edge_list =
- let built_nodes = List.map (Node.build ?domain) full_node_list in
+ let built_nodes = List.map (P_node.build ?domain) full_node_list in
let (old_nodes, new_nodes) =
List.partition
@@ -122,14 +105,14 @@ module Graph = struct
(* the nodes, in the same order stored with index -1, -2, ... -N *)
let ext_map_without_edges =
List_.foldi_left
- (fun i acc elt -> IntMap.add (-i-1) elt acc)
- IntMap.empty
+ (fun i acc elt -> Pid_map.add (-i-1) elt acc)
+ Pid_map.empty
new_node_list in
let old_map_without_edges =
List.fold_left
- (fun acc (id,node) -> IntMap.add (Array_.dicho_find id old_table) node acc)
- IntMap.empty
+ (fun acc (id,node) -> Pid_map.add (Array_.dicho_find id old_table) node acc)
+ Pid_map.empty
old_nodes in
let ext_map_with_all_edges =
@@ -141,99 +124,13 @@ module Graph = struct
let i2 =
match Id.build_opt ast_edge.Ast.tar old_table
with Some i -> i | None -> -1-(Id.build ~loc ast_edge.Ast.tar new_table) in
- let edge = Edge.build ~locals (ast_edge, loc) in
+ let edge = P_edge.build ~locals (ast_edge, loc) in
match map_add_edge acc i1 edge i2 with
| Some map -> map
- | None -> Log.fbug "[GRS] [Graph.build_extention] add_edge cannot fail in pattern extention (1)"; exit 2
+ | None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension (1)"; exit 2
) ext_map_without_edges full_edge_list in
({ext_map = ext_map_with_all_edges; old_map = old_map_without_edges}, new_table)
-
- (* ---------------------------------------------------------------------------------------------------- *)
- (* Output functions *)
- (* ---------------------------------------------------------------------------------------------------- *)
- let to_gr graph =
- let buff = Buffer.create 32 in
-
- bprintf buff "graph {\n";
-
- (* list of the nodes *)
- IntMap.iter
- (fun id node ->
- bprintf buff "N%d %s [%s];\n"
- id
- (match node.Node.pos with Some i -> sprintf "(%d)" i | None -> "")
- (Feature_structure.to_gr node.Node.fs)
- ) graph.map;
- (* list of the edges *)
- IntMap.iter
- (fun id node ->
- Massoc.iter
- (fun tar edge ->
- bprintf buff "N%d -[%s]-> N%d;\n" id (Edge.to_string edge) tar
- ) node.Node.next
- ) graph.map;
-
- bprintf buff "}\n";
- Buffer.contents buff
-
-
- let to_dot ?main_feat ?(deco=Deco.empty) graph =
- let buff = Buffer.create 32 in
-
- bprintf buff "digraph G {\n";
- bprintf buff " rankdir=LR;\n";
- bprintf buff " node [shape=Mrecord];\n";
-
- (* list of the nodes *)
- IntMap.iter
- (fun id node ->
- bprintf buff " N%d [label=\"%s\", color=%s]\n"
- id
- (Feature_structure.to_dot ?main_feat node.Node.fs)
- (if List.mem id deco.Deco.nodes then "red" else "black")
- ) graph.map;
- (* list of the edges *)
- IntMap.iter
- (fun id node ->
- Massoc.iter
- (fun tar edge ->
- let deco = List.mem (id,Edge.as_label edge,tar) deco.Deco.edges in
- bprintf buff " N%d -> N%d%s\n" id tar (Edge.to_dot ~deco edge)
- ) node.Node.next
- ) graph.map;
-
- bprintf buff "}\n";
- Buffer.contents buff
-
- let to_dep ?main_feat ?(deco=Deco.empty) graph =
- let buff = Buffer.create 32 in
- bprintf buff "[GRAPH] { opacity=0; scale = 200; fontname=\"Arial\"; }\n";
-
- bprintf buff "[WORDS] { \n";
-
- let nodes = IntMap.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
- let snodes = List.sort (fun (_,n1) (_,n2) -> Pervasives.compare n1.Node.pos n2.Node.pos) nodes in
-
- List.iter
- (fun (id, node) ->
- if List.mem id deco.Deco.nodes
- then bprintf buff "N%d { %sforecolor=red; subcolor=red; }\n" id (Feature_structure.to_dep ?main_feat node.Node.fs)
- else bprintf buff "N%d { %s }\n" id (Feature_structure.to_dep ?main_feat node.Node.fs)
- ) snodes;
- bprintf buff "} \n";
-
- bprintf buff "[EDGES] { \n";
- IntMap.iter
- (fun id elt ->
- Massoc.iter
- (fun tar edge ->
- let deco = List.mem (id,Edge.as_label edge,tar) deco.Deco.edges in
- bprintf buff "N%d -> N%d %s\n" id tar (Edge.to_dep ~deco edge)
- ) elt.Node.next
- ) graph.map;
- bprintf buff "} \n";
- Buffer.contents buff
(* ---------------------------------------------------------------------------------------------------- *)
(* Topology functions *)
@@ -245,7 +142,7 @@ module Graph = struct
let tree_and_roots graph =
let tree_prop = ref true in
let not_root =
- IntMap.fold
+ Pid_map.fold
(fun _ node acc ->
Massoc.fold_left
(fun acc2 tar _ ->
@@ -255,67 +152,157 @@ module Graph = struct
then (tree_prop := false; acc2)
else IntSet.add tar acc2
else IntSet.add tar acc2
- ) acc node.Node.next
- ) graph.map IntSet.empty in
+ ) acc (P_node.get_next node)
+ ) graph IntSet.empty in
let roots =
- IntMap.fold
+ Pid_map.fold
(fun id _ acc ->
if IntSet.mem id not_root
then acc
else id::acc
- ) graph.map [] in
+ ) graph [] in
(!tree_prop, roots)
let roots graph = snd (tree_and_roots graph)
+end (* module P_graph *)
+(* ================================================================================ *)
- (* ---------------------------------------------------------------------------------------------------- *)
+
+
+(* ================================================================================ *)
+module Gid = struct
+ type t = int
+ let compare = Pervasives.compare
+end
+
+module Gid_map = Map.Make (Gid)
+(* ================================================================================ *)
+
+(* ================================================================================ *)
+module G_graph = struct
+ type t = {
+ map: G_node.t Gid_map.t; (* node description *)
+ lub: int; (* least upper bound *)
+ }
+
+ let empty = {map = Gid_map.empty; lub = 0}
+
+ let find node_id graph = Gid_map.find node_id graph.map
+
+ type concat_item =
+ | Feat of (Gid.t * string)
+ | String of string
+
+
+ let map_add_edge map id_src label id_tar =
+ let node_src =
+ (* Not found can be raised when adding an edge from pos to neg *)
+ try Gid_map.find id_src map with Not_found -> G_node.empty in
+ match G_node.add_edge label id_tar node_src with
+ | None -> None
+ | Some new_node -> Some (Gid_map.add id_src new_node map)
+
+
+ let build ?domain ?(locals=[||]) full_node_list full_edge_list =
+
+ let (named_nodes, constraints) =
+ let rec loop already_bound = function
+ | [] -> ([],[])
+ | (ast_node, loc) :: tail ->
+ let (tail_nodes, tail_const) = loop (ast_node.Ast.node_id :: already_bound) tail in
+ if List.mem ast_node.Ast.node_id already_bound
+ then (tail_nodes, (ast_node, loc)::tail_const)
+ else (G_node.build ?domain (ast_node, loc) :: tail_nodes, tail_const) in
+ loop [] full_node_list in
+
+ (* let named_nodes = List.map (Node.build ?domain) full_node_list in *)
+
+ let sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) named_nodes in
+ let (sorted_ids, node_list) = List.split sorted_nodes in
+
+ (* table contains the sorted list of node ids *)
+ let table = Array.of_list sorted_ids in
+
+ (* the nodes, in the same order *)
+ let map_without_edges = List_.foldi_left (fun i acc elt -> Gid_map.add i elt acc) Gid_map.empty node_list in
+
+ let map =
+ List.fold_left
+ (fun acc (ast_edge, loc) ->
+ let i1 = Id.build ~loc ast_edge.Ast.src table in
+ let i2 = Id.build ~loc ast_edge.Ast.tar table in
+ let edge = G_edge.build ~locals (ast_edge, loc) in
+ (match map_add_edge acc i1 edge i2 with
+ | Some g -> g
+ | None -> Log.fcritical "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
+ (G_edge.to_string edge)
+ (Loc.to_string loc)
+ )
+ ) map_without_edges full_edge_list in
+
+ {map=map;lub=Array.length table}
+
+
+ (* ---------------------------------------------------- *)
(* Update functions *)
- (* ---------------------------------------------------------------------------------------------------- *)
+ (* ---------------------------------------------------- *)
+
+
+
+ (* [add_edge graph id_src label id_tar] tries to add an edge grom [id_src] to [id_tar] with [label] to [graph].
+ if it succeeds, [Some new_graph] is returned
+ if it fails (the edge already exists), [None] is returned
+ *)
+ let add_edge graph id_src label id_tar =
+ match map_add_edge graph.map id_src label id_tar with
+ | Some new_map -> Some {graph with map = new_map}
+ | None -> None
+
(* remove (id_src -[label]-> id_tar) from graph.
Log.critical if the edge is not in graph *)
let del_edge ?edge_ident loc graph id_src label id_tar =
let node_src =
- try IntMap.find id_src graph.map
+ try Gid_map.find id_src graph.map
with Not_found ->
match edge_ident with
| None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report"
| Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in
try {graph with map =
- IntMap.add id_src {node_src with Node.next = Massoc.remove id_tar label node_src.Node.next} graph.map
+ (* Gid_map.add id_src {node_src with Node.next = Massoc.remove id_tar label node_src.Node.next} graph.map *)
+ Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map
}
- with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (Edge.to_string label)
+ with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label)
(* remove node i from graph, with all its incoming and outcoming edges *)
(* [graph] is unchanged if the node is not in it *)
let del_node graph node_id =
let new_map =
- IntMap.fold
+ Gid_map.fold
(fun id value acc ->
if id = node_id
then acc
- else IntMap.add id {value with Node.next = try Massoc.remove_key node_id value.Node.next with Not_found -> value.Node.next} acc
- ) graph.map IntMap.empty in
+ (* else Gid_map.add id {value with Node.next = try Massoc.remove_key node_id value.Node.next with Not_found -> value.Node.next} acc *)
+ else Gid_map.add id (G_node.remove_key node_id value) acc
+ ) graph.map Gid_map.empty in
{graph with map = new_map}
- let add_neighbour loc graph node_id edge =
- let label = Edge.as_label edge in
+ let add_neighbour loc graph node_id label =
(* index is a new number (higher then lub and uniquely defined by (node_id,label) *)
- let index = graph.lub + ((Grew_edge.Label.to_int label) * graph.lub) + node_id in
+ let index = graph.lub + ((Label.to_int label) * graph.lub) + node_id in
- if IntMap.mem index graph.map
+ if Gid_map.mem index graph.map
then Error.run ~loc "[Graph.add_neighbour] try to build twice the \"same\" neighbour node (with label '%s')" (Label.to_string label);
- let node = IntMap.find node_id graph.map in
+ let node = Gid_map.find node_id graph.map in
(* put the new node on the right of its "parent" *)
- let new_node = {Node.empty with Node.pos = match node.Node.pos with Some x -> Some (x+1) | None -> None} in
- let new_graph = {graph with map = IntMap.add index new_node graph.map} in
- match add_edge new_graph node_id (Edge.of_label label) index with
+ let new_graph = {graph with map = Gid_map.add index (G_node.build_neighbour node) graph.map} in
+ match add_edge new_graph node_id label index with
| Some g -> (index, g)
| None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1
@@ -323,134 +310,205 @@ module Graph = struct
(* move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
let shift_in loc graph src_gid tar_gid =
- let tar_node = IntMap.find tar_gid graph.map in
+ let tar_node = Gid_map.find tar_gid graph.map in
- if Massoc.mem_key src_gid tar_node.Node.next
+ if Massoc.mem_key src_gid (G_node.get_next tar_node)
then Error.run ~loc "[Graph.shift_in] dependency from tar to src";
let new_map =
- IntMap.mapi
+ Gid_map.mapi
(fun node_id node ->
- try {node with Node.next = Massoc.merge_key src_gid tar_gid node.Node.next}
- with Massoc.Duplicate -> Error.run ~loc "[Graph.shift_edges] create duplicate edge"
+ match G_node.merge_key src_gid tar_gid node with
+ | Some n -> n
+ | None -> Error.run ~loc "[Graph.shift_edges] create duplicate edge"
) graph.map
in {graph with map = new_map}
(* move all out-edges from id_src are moved to out-edges out off node id_tar *)
let shift_out loc graph src_gid tar_gid =
- let src_node = IntMap.find src_gid graph.map in
- let tar_node = IntMap.find tar_gid graph.map in
+ let src_node = Gid_map.find src_gid graph.map in
+ let tar_node = Gid_map.find tar_gid graph.map in
- if Massoc.mem_key tar_gid src_node.Node.next
+ if Massoc.mem_key tar_gid (G_node.get_next src_node)
then Error.run ~loc "[Graph.shift_edges] dependency from src to tar";
let new_map =
- IntMap.mapi
+ Gid_map.mapi
(fun node_id node ->
if node_id = src_gid
then (* [src_id] becomes without out-edges *)
- {node with Node.next = Massoc.empty}
+ G_node.rm_out_edges node
else if node_id = tar_gid
then
- try {node with Node.next = Massoc.disjoint_union src_node.Node.next tar_node.Node.next}
- with Massoc.Not_disjoint -> Error.run ~loc "[Graph.shift_edges] common successor"
+ match G_node.shift_out src_node tar_node with
+ | Some n -> n
+ | None -> Error.run ~loc "[Graph.shift_edges] common successor"
else node (* other nodes don't change *)
) graph.map
in {graph with map = new_map}
(* 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 *)
let shift_edges loc graph src_gid tar_gid =
- let src_node = IntMap.find src_gid graph.map in
- let tar_node = IntMap.find tar_gid graph.map in
+ let src_node = Gid_map.find src_gid graph.map in
+ let tar_node = Gid_map.find tar_gid graph.map in
- if Massoc.mem_key tar_gid src_node.Node.next
+ if Massoc.mem_key tar_gid (G_node.get_next src_node)
then Error.run ~loc "[Graph.shift_edges] dependency from src to tar";
- if Massoc.mem_key src_gid tar_node.Node.next
+ if Massoc.mem_key src_gid (G_node.get_next tar_node)
then Error.run ~loc "[Graph.shift_edges] dependency from tar to src";
let new_map =
- IntMap.mapi
+ Gid_map.mapi
(fun node_id node ->
if node_id = src_gid
then (* [src_id] becomes an isolated node *)
- {node with Node.next = Massoc.empty}
+ G_node.rm_out_edges node
else if node_id = tar_gid
then
- try {node with Node.next = Massoc.disjoint_union src_node.Node.next tar_node.Node.next}
- with Massoc.Not_disjoint -> Error.run ~loc "[Graph.shift_edges] common successor"
- else
- try {node with Node.next = Massoc.merge_key src_gid tar_gid node.Node.next}
- with Massoc.Duplicate -> Error.run ~loc "[Graph.shift_edges] create duplicate edge"
+ match G_node.shift_out src_node tar_node with
+ | Some n -> n
+ | None -> Error.run ~loc "[Graph.shift_edges] common successor"
+ else
+ match G_node.merge_key src_gid tar_gid node with
+ | Some n -> n
+ | None -> Error.run ~loc "[Graph.shift_edges] create duplicate edge"
) graph.map
in {graph with map = new_map}
-
-
-
-
-
-
-
-
-
-
-
-
-
-
let merge_node loc graph src_gid tar_gid =
let se_graph = shift_edges loc graph src_gid tar_gid in
- let src_node = IntMap.find src_gid se_graph.map in
- let tar_node = IntMap.find tar_gid se_graph.map in
+ let src_node = Gid_map.find src_gid se_graph.map in
+ let tar_node = Gid_map.find tar_gid se_graph.map in
- match Feature_structure.unif src_node.Node.fs tar_node.Node.fs with
+ match Feature_structure.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
| Some new_fs ->
let new_map =
- IntMap.add
+ Gid_map.add
tar_gid
- {tar_node with Node.fs = new_fs}
- (IntMap.remove src_gid se_graph.map) in
+ (G_node.set_fs tar_node new_fs)
+ (Gid_map.remove src_gid se_graph.map) in
Some {se_graph with map = new_map}
| None -> None
(* FIXME: check consistency wrt the domain *)
let update_feat graph tar_id tar_feat_name item_list =
- let tar = IntMap.find tar_id graph.map in
+ let tar = Gid_map.find tar_id graph.map in
let strings_to_concat =
List.map
(function
| Feat (node_gid, feat_name) ->
- let node = IntMap.find node_gid graph.map in
+ let node = Gid_map.find node_gid graph.map in
(try
- match Feature_structure.get_atom feat_name node.Node.fs with
+ match Feature_structure.get_atom feat_name (G_node.get_fs node) with
| Some atom -> atom
| None -> Log.fcritical "[BUG] [Graph.update_feat] Feature not atomic"
with Not_found ->
Log.fcritical "[RUN] [Graph.update_feat] no feature \"%s\" in node \"%s\""
- feat_name (Node.to_string node))
+ feat_name (G_node.to_string node))
| String s -> s
) item_list in
let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
- let new_f = Feature_structure.set_feat tar_feat_name [new_feature_value] tar.Node.fs in
- ({graph with map = IntMap.add tar_id {tar with Node.fs = new_f} graph.map}, new_feature_value)
+ let new_fs = Feature_structure.set_feat tar_feat_name [new_feature_value] (G_node.get_fs tar) in
+ ({graph with map = Gid_map.add tar_id (G_node.set_fs tar new_fs) graph.map}, new_feature_value)
(** [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. *)
let del_feat graph node_id feat_name =
- let node = IntMap.find node_id graph.map in
- let new_fs = Feature_structure.del_feat feat_name node.Node.fs in
- {graph with map = IntMap.add node_id {node with Node.fs = new_fs} graph.map}
+ let node = Gid_map.find node_id graph.map in
+ let new_fs = Feature_structure.del_feat feat_name (G_node.get_fs node) in
+ {graph with map = Gid_map.add node_id (* {node with Node.fs = new_fs} *) (G_node.set_fs node new_fs) graph.map}
+
+ let to_gr graph =
+ let buff = Buffer.create 32 in
+
+ bprintf buff "graph {\n";
+
+ (* list of the nodes *)
+ Gid_map.iter
+ (fun id node ->
+ bprintf buff "N%d %s;\n" id (G_node.to_gr node)
+ ) graph.map;
+ (* list of the edges *)
+ Gid_map.iter
+ (fun id node ->
+ Massoc.iter
+ (fun tar edge ->
+ bprintf buff "N%d -[%s]-> N%d;\n" id (G_edge.to_string edge) tar
+ ) (G_node.get_next node)
+ ) graph.map;
+
+ bprintf buff "}\n";
+ Buffer.contents buff
+
+ let to_dep ?main_feat ?(deco=Deco.empty) graph =
+ let buff = Buffer.create 32 in
+ bprintf buff "[GRAPH] { opacity=0; scale = 200; fontname=\"Arial\"; }\n";
+
+ bprintf buff "[WORDS] { \n";
+
+ let nodes = Gid_map.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
+ let snodes = List.sort (fun (_,n1) (_,n2) -> G_node.pos_comp n1 n2) nodes in
+
+ List.iter
+ (fun (id, node) ->
+ if List.mem id deco.Deco.nodes
+ then bprintf buff
+ "N%d { %sforecolor=red; subcolor=red; }\n" id (Feature_structure.to_dep ?main_feat (G_node.get_fs node))
+ else bprintf buff
+ "N%d { %s }\n" id (Feature_structure.to_dep ?main_feat (G_node.get_fs node))
+ ) snodes;
+ bprintf buff "} \n";
+
+ bprintf buff "[EDGES] { \n";
+ Gid_map.iter
+ (fun gid elt ->
+ Massoc.iter
+ (fun tar g_edge ->
+ let deco = List.mem (gid,g_edge,tar) deco.Deco.edges in
+ bprintf buff "N%d -> N%d %s\n" gid tar (G_edge.to_dep ~deco g_edge)
+ ) (G_node.get_next elt)
+ ) graph.map;
+ bprintf buff "} \n";
+ Buffer.contents buff
+
+ let to_dot ?main_feat ?(deco=Deco.empty) graph =
+ let buff = Buffer.create 32 in
+
+ bprintf buff "digraph G {\n";
+ bprintf buff " rankdir=LR;\n";
+ bprintf buff " node [shape=Mrecord];\n";
+
+ (* list of the nodes *)
+ Gid_map.iter
+ (fun id node ->
+ bprintf buff " N%d [label=\"%s\", color=%s]\n"
+ id
+ (Feature_structure.to_dot ?main_feat (G_node.get_fs node))
+ (if List.mem id deco.Deco.nodes then "red" else "black")
+ ) graph.map;
+ (* list of the edges *)
+ Gid_map.iter
+ (fun id node ->
+ Massoc.iter
+ (fun tar g_edge ->
+ let deco = List.mem (id,g_edge,tar) deco.Deco.edges in
+ bprintf buff " N%d -> N%d%s\n" id tar (G_edge.to_dot ~deco g_edge)
+ ) (G_node.get_next node)
+ ) graph.map;
+
+ bprintf buff "}\n";
+ Buffer.contents buff
- let equals t t' = IntMap.equal (fun node1 node2 -> node1 = node2) t.map t'.map
+ let equals t t' = Gid_map.equal (fun node1 node2 -> node1 = node2) t.map t'.map
(* is there an edge e out of node i ? *)
- let edge_out graph node_id edge =
- let node = IntMap.find node_id graph.map in
- Massoc.exists (fun _ e -> Edge.compatible e edge) node.Node.next
-
-end (* module Graph *)
+ let edge_out graph node_id p_edge =
+ let node = Gid_map.find node_id graph.map in
+ Massoc.exists (fun _ e -> P_edge.compatible p_edge e) (G_node.get_next node)
+end (* module G_graph *)
+(* ================================================================================ *)
diff --git a/src/grew_graph.mli b/src/grew_graph.mli
index a7fd944ff24ba604942088c8d186026ab6fe554d..a8107c3f787433007f69fabba8c5f9d3768377df 100644
--- a/src/grew_graph.mli
+++ b/src/grew_graph.mli
@@ -3,7 +3,6 @@ open Grew_fs
open Grew_edge
open Grew_node
open Grew_utils
-open Edge
open Grew_command
module Deco: sig
@@ -14,19 +13,16 @@ module Deco: sig
val empty:t
end
-module Graph : sig
- type t = {
- map: Node.t IntMap.t; (* node description *)
- lub: int; (* least upper bound *)
- }
-
- type gid = int
-
- type concat_item =
- | Feat of (gid * string)
- | String of string
+module P_graph: sig
+ type t = P_node.t Pid_map.t
val empty: t
+ val find: Pid.t -> t -> P_node.t
+
+ type extension = {
+ ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New" *)
+ old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
+ }
val build:
?domain: Ast.domain ->
@@ -35,30 +31,54 @@ module Graph : sig
Ast.edge list ->
(t * Id.table * (Id.t * Feature_structure.t) list )
- (* a type for extension of graph: a former graph exists: in grew the former is a positive pattern and an extension is a "without" *)
- type extention = {
- ext_map: Node.t IntMap.t; (* node description *)
- old_map: Node.t IntMap.t; (* a partial map on old nodes for edge "Old -> New" and/or for new constraints on old nodes "Old [...]" *)
- }
-
- val build_extention:
+ val build_extension:
?domain: Ast.domain ->
?locals: Label.decl array ->
Id.table ->
Ast.node list ->
Ast.edge list ->
- (extention * Id.table)
+ (extension * Id.table)
+
+ val roots: t -> Pid.t list
+
+end
+
+module Gid : sig type t = int end
+
+module Gid_map : Map.S with type key = Gid.t
+
+
+module G_graph: sig
+ type t = {
+ map: G_node.t Gid_map.t; (* node description *)
+ lub: int; (* least upper bound *)
+ }
+
+
+ val empty: t
- val find: int -> t -> Node.t
+ val find: Gid.t -> t -> G_node.t
+
+ val build:
+ ?domain: Ast.domain ->
+ ?locals: Label.decl array ->
+ Ast.node list ->
+ Ast.edge list ->
+ t
val to_gr: t -> string
val to_dot: ?main_feat:string -> ?deco:Deco.t -> t -> string
val to_dep: ?main_feat:string -> ?deco:Deco.t -> t -> string
- val add_edge : t -> int -> Edge.t -> int -> t option
- val del_edge : ?edge_ident: string -> Loc.t -> t -> int -> Edge.t -> int -> t
+
+ type concat_item =
+ | Feat of (Gid.t * string)
+ | String of string
+
+ val add_edge: t -> int -> G_edge.t -> int -> t option
+ val del_edge : ?edge_ident: string -> Loc.t -> t -> int -> G_edge.t -> int -> t
val del_node : t -> int -> t
- val add_neighbour : Loc.t -> t -> int -> Edge.t -> (int * t)
+ val add_neighbour : Loc.t -> t -> int -> G_edge.t -> (int * t)
val merge_node : Loc.t -> t -> int -> int -> t option
val shift_in : Loc.t -> t -> int -> int -> t
@@ -72,11 +92,10 @@ module Graph : sig
val del_feat : t -> int -> string -> t
- val equals : t -> t -> bool
-
(** [edge_out t id edge] returns true iff there is an out-edge from the node [id] with a label compatible with [edge] *)
- val edge_out: t -> int -> Edge.t -> bool
+ val edge_out: t -> int -> P_edge.t -> bool
+
+ val equals: t -> t -> bool
- val roots: t -> int list
end
diff --git a/src/grew_node.ml b/src/grew_node.ml
index 75eac229e13cabbc5dd7f3c17907ae2dbbed4ac4..93408d11be7b84759c087cabc1e2bbd7e6811d89 100644
--- a/src/grew_node.ml
+++ b/src/grew_node.ml
@@ -1,18 +1,39 @@
+open Printf
+
open Grew_utils
open Grew_ast
open Grew_edge
open Grew_fs
-
-module Node = struct
+(* ================================================================================ *)
+module G_node = struct
type t = {
- fs : Feature_structure.t;
- pos : int option;
- next : Edge.t Massoc.t; (* the massoc gives for each node [n], the (sorted) list of edge from the current node to [n] *)
+ fs: Feature_structure.t;
+ pos: int option;
+ next: G_edge.t Massoc.t;
}
- let empty = {fs = Feature_structure.empty; pos=None; next = Massoc.empty}
-
+ let get_fs t = t.fs
+ let get_next t = t.next
+
+ let set_fs t fs = {t with fs = fs}
+
+ let empty = { fs = Feature_structure.empty; pos = None; next = Massoc.empty }
+
+ let to_string t =
+ Printf.sprintf "[fs=%s ; next=%s]"
+ (Feature_structure.to_string t.fs)
+ (Massoc.to_string G_edge.to_string t.next)
+
+ let to_gr t =
+ sprintf "%s [%s] "
+ (match t.pos with Some i -> sprintf "(%d)" i | None -> "")
+ (Feature_structure.to_gr t.fs)
+
+ let add_edge g_edge gid_tar t =
+ match Massoc.add gid_tar g_edge t.next with
+ | Some l -> Some {t with next = l}
+ | None -> None
let build ?domain (ast_node, loc) =
(ast_node.Ast.node_id,
@@ -20,13 +41,57 @@ module Node = struct
pos = ast_node.Ast.position;
next = Massoc.empty;
} )
-
+
+ let remove id_tar label t = {t with next = Massoc.remove id_tar label t.next}
+
+ let remove_key node_id t =
+ try {t with next = Massoc.remove_key node_id t.next} with Not_found -> t
+
+ let merge_key src_id tar_id t =
+ try Some {t with next = Massoc.merge_key src_id tar_id t.next}
+ with Massoc.Duplicate -> None
+
+ let shift_out src_t tar_t =
+ try Some {tar_t with next = Massoc.disjoint_union src_t.next tar_t.next}
+ with Massoc.Not_disjoint -> None
+
+ let rm_out_edges t = {t with next = Massoc.empty}
+
+
+ let build_neighbour t = {empty with pos = match t.pos with Some x -> Some (x+1) | None -> None}
+
+ let pos_comp n1 n2 = Pervasives.compare n1.pos n2.pos
+end
+(* ================================================================================ *)
+
+(* ================================================================================ *)
+module P_node = struct
+ type t = {
+ fs: Feature_structure.t;
+ next: P_edge.t Massoc.t;
+ }
+
+ let get_fs t = t.fs
+ let get_next t = t.next
+
+ let empty = { fs = Feature_structure.empty; next = Massoc.empty }
+
+ let build ?domain (ast_node, loc) =
+ (ast_node.Ast.node_id,
+ { fs = Feature_structure.build ?domain ast_node.Ast.fs;
+ next = Massoc.empty;
+ } )
+
+ let add_edge p_edge pid_tar t =
+ match Massoc.add pid_tar p_edge t.next with
+ | Some l -> Some {t with next = l}
+ | None -> None
(* Says that "pattern" t1 is a t2*)
- let is_a pattern graph = Feature_structure.compatible pattern.fs graph.fs
+ let is_a p_node g_node = Feature_structure.compatible p_node.fs (G_node.get_fs g_node)
- let to_string t =
- Printf.sprintf "[fs=%s ; next=%s]"
- (Feature_structure.to_string t.fs)
- (Massoc.to_string Edge.to_string t.next)
end
+(* ================================================================================ *)
+
+
+
diff --git a/src/grew_node.mli b/src/grew_node.mli
index bf7535e6b3940b6d90facbadc95285513f9931c7..82d15f5aa8dd80a0267dc206ebabc2edcd77115e 100644
--- a/src/grew_node.mli
+++ b/src/grew_node.mli
@@ -3,17 +3,52 @@ open Grew_fs
open Grew_edge
open Grew_ast
-module Node : sig
- type t = {
- fs : Feature_structure.t;
- pos : int option;
- next : Edge.t Massoc.t;
- }
-
+(* ================================================================================ *)
+module G_node: sig
+ type t
+
+ val empty: t
+
+ val to_string: t -> string
+ val to_gr: t -> string
+
+ val get_fs: t -> Feature_structure.t
+ val get_next: t -> G_edge.t Massoc.t
+
+ val set_fs: t -> Feature_structure.t -> t
+
+(* FIXME move Gid up and replace int by Gid.t *)
+ val remove: int -> G_edge.t -> t -> t
+
+ val remove_key: int -> t -> t
+
+ val merge_key: int -> int -> t -> t option
+ val shift_out: t -> t -> t option
+
+ val rm_out_edges: t -> t
+
+ val add_edge: G_edge.t -> int -> t -> t option
val build: ?domain:Ast.domain -> Ast.node -> (Id.name * t)
+ val pos_comp: t -> t -> int
+
+ val build_neighbour: t -> t
+end
+(* ================================================================================ *)
+
+(* ================================================================================ *)
+module P_node: sig
+ type t
+
+ val empty: t
+
+ val get_fs: t -> Feature_structure.t
+ val get_next: t -> P_edge.t Massoc.t
+
+ val build: ?domain:Ast.domain -> Ast.node -> (Id.name * t)
+
+ val add_edge: P_edge.t -> int -> t -> t option
+
+ val is_a: t -> G_node.t -> bool
- val is_a : t -> t -> bool
- val empty : t
- val to_string : t -> string
end
-
+(* ================================================================================ *)
diff --git a/src/grew_rule.ml b/src/grew_rule.ml
index b6d5df691774b7480a8c1d2bc60b06eb29739602..ca7723e4f0b40b296380050840680729a07a229d 100644
--- a/src/grew_rule.ml
+++ b/src/grew_rule.ml
@@ -14,20 +14,21 @@ open Dep2pict
ENDIF
+(* ================================================================================ *)
module Instance = struct
type t = {
- graph: Graph.t;
+ graph: G_graph.t;
commands: Command.h list;
rules: string list;
big_step: Grew_types.big_step option;
}
- let empty = {graph = Graph.empty; rules=[]; commands=[]; big_step=None;}
+ let empty = {graph = G_graph.empty; rules=[]; commands=[]; big_step=None;}
let from_graph g = {empty with graph = g}
let build gr_ast =
- let (graph,_,_) = Graph.build gr_ast.Ast.nodes gr_ast.Ast.edges in
+ let graph = G_graph.build gr_ast.Ast.nodes gr_ast.Ast.edges in
{ empty with graph = graph }
let rev_steps t =
@@ -39,51 +40,50 @@ module Instance = struct
let clear t = {empty with graph = t.graph } (* FIXME: normalization of node ids ??? *)
let get_graph t = t.graph
- (* comparition is done on the list of commands *)
+ (* comparison is done on the list of commands *)
(* only graph rewrited from the same init graph can be "compared" *)
let compare t1 t2 = Pervasives.compare t1.commands t2.commands
IFDEF DEP2PICT THEN
let save_dep_png ?main_feat base t =
- ignore (Dep2pict.fromDepStringToPng (Graph.to_dep ?main_feat t.graph) (base^".png"))
+ ignore (Dep2pict.fromDepStringToPng (G_graph.to_dep ?main_feat t.graph) (base^".png"))
ENDIF
-
-end
+end (* module Instance *)
module Instance_set = Set.Make (Instance)
-
+(* ================================================================================ *)
module Rule = struct
- type pid = int
+ type pid = Pid.t
type gid = int
let max_depth = ref 500
exception Bound_reached
type const =
- | No_out of pid * Edge.t
- | No_in of pid * Edge.t
+ | No_out of pid * P_edge.t
+ | No_in of pid * P_edge.t
| Feature_eq of pid * string * pid * string
| Filter of pid * Feature_structure.t (* used when a without impose a fs on a node defined by the match pattern *)
let build_constraint ?locals table = function
- | (Ast.Start (node_name, labels), loc) -> No_out (Id.build ~loc node_name table, Edge.make ?locals labels)
- | (Ast.No_out node_name, loc) -> No_out (Id.build ~loc node_name table, Edge.all)
- | (Ast.End (node_name, labels),loc) -> No_in (Id.build ~loc node_name table, Edge.make ?locals labels)
- | (Ast.No_in node_name, loc) -> No_in (Id.build ~loc node_name table, Edge.all)
+ | (Ast.Start (node_name, labels), loc) -> No_out (Id.build ~loc node_name table, P_edge.make ?locals labels)
+ | (Ast.No_out node_name, loc) -> No_out (Id.build ~loc node_name table, P_edge.all)
+ | (Ast.End (node_name, labels),loc) -> No_in (Id.build ~loc node_name table, P_edge.make ?locals labels)
+ | (Ast.No_in node_name, loc) -> No_in (Id.build ~loc node_name table, P_edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (Id.build ~loc node_name1 table, feat_name1, Id.build ~loc node_name2 table, feat_name2)
type pattern =
- { graph: Graph.t;
+ { graph: P_graph.t;
constraints: const list;
}
let build_pos_pattern ?domain ?(locals=[||]) pattern_ast =
- let (graph,table,filter_nodes) = Graph.build ?domain ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
+ let (graph,table,filter_nodes) = P_graph.build ?domain ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
(
{
graph = graph;
@@ -99,32 +99,32 @@ module Rule = struct
let id_build loc string_id =
match Id.build_opt string_id pos_table with Some i -> i | None -> -1-(Id.build ~loc string_id neg_table) in
match const with
- | (Ast.Start (node_name, labels),loc) -> No_out (id_build loc node_name, Edge.make ?locals labels)
- | (Ast.No_out node_name, loc) -> No_out (id_build loc node_name, Edge.all)
- | (Ast.End (node_name, labels),loc) -> No_in (id_build loc node_name, Edge.make ?locals labels)
- | (Ast.No_in node_name, loc) -> No_in (id_build loc node_name, Edge.all)
+ | (Ast.Start (node_name, labels),loc) -> No_out (id_build loc node_name, P_edge.make ?locals labels)
+ | (Ast.No_out node_name, loc) -> No_out (id_build loc node_name, P_edge.all)
+ | (Ast.End (node_name, labels),loc) -> No_in (id_build loc node_name, P_edge.make ?locals labels)
+ | (Ast.No_in node_name, loc) -> No_in (id_build loc node_name, P_edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (id_build loc node_name1, feat_name1, id_build loc node_name2, feat_name2)
let build_neg_pattern ?domain ?(locals=[||]) pos_table pattern_ast =
let (extension, neg_table) =
- Graph.build_extention ?domain ~locals pos_table pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
+ P_graph.build_extension ?domain ~locals pos_table pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
- let filters = IntMap.fold (fun id node acc -> Filter (id, node.Node.fs) :: acc) extension.Graph.old_map [] in
+ let filters = Pid_map.fold (fun id node acc -> Filter (id, P_node.get_fs node) :: acc) extension.P_graph.old_map [] in
(* (\* DEBUG *\) Printf.printf "-----> |filters| = %d\n%!" (List.length filters); *)
{
- graph = {Graph.map = extension.Graph.ext_map; lub=0 };
+ graph = extension.P_graph.ext_map;
constraints = filters @ List.map (build_neg_constraint ~locals pos_table neg_table) pattern_ast.Ast.pat_const ;
}
let get_edge_ids pattern =
- IntMap.fold
+ Pid_map.fold
(fun _ node acc ->
Massoc.fold_left
- (fun acc2 _ edge -> match Edge.get_id edge with None -> acc2 | Some id -> id::acc2)
- acc node.Node.next
- ) pattern.graph.Graph.map []
+ (fun acc2 _ edge -> match P_edge.get_id edge with None -> acc2 | Some id -> id::acc2)
+ acc (P_node.get_next node)
+ ) pattern.graph []
type t = {
name: string;
@@ -161,19 +161,19 @@ module Rule = struct
}
type matching = {
- n_match: gid IntMap.t; (* partial fct: pattern nodes |--> graph nodes *)
+ n_match: gid Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(gid*Label.t*gid)) list; (* edge matching: edge ident |--> (src,label,tar) *)
a_match: (gid*Label.t*gid) list; (* anonymous edge mached *)
}
- let empty_matching = { n_match = IntMap.empty; e_match = []; a_match = [];}
+ let empty_matching = { n_match = Pid_map.empty; e_match = []; a_match = [];}
- let singleton_matching i j = { empty_matching with n_match = IntMap.add i j IntMap.empty }
+ let singleton_matching i j = { empty_matching with n_match = Pid_map.add i j Pid_map.empty }
let e_comp (e1,_) (e2,_) = compare e1 e2
let union match1 match2 = {
- n_match = IntMap.union_if match1.n_match match2.n_match;
+ n_match = Pid_map.union_if match1.n_match match2.n_match;
e_match = List_.sort_disjoint_union ~compare:e_comp match1.e_match match2.e_match;
a_match = match1.a_match @ match2.a_match;
}
@@ -186,14 +186,14 @@ module Rule = struct
let a_match_add edge matching = {matching with a_match = edge::matching.a_match }
let up_deco matching =
- { Deco.nodes = IntMap.fold (fun _ gid acc -> gid::acc) matching.n_match [];
+ { Deco.nodes = Pid_map.fold (fun _ gid acc -> gid::acc) matching.n_match [];
Deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match;
}
let find cnode ?loc (matching, created_nodes) =
match cnode with
| Command.Pid pid ->
- (try IntMap.find pid matching.n_match
+ (try Pid_map.find pid matching.n_match
with Not_found -> Error.bug ?loc "Inconsistent matching pid '%d' not found" pid)
| Command.New name ->
try List.assoc name created_nodes
@@ -212,7 +212,7 @@ module Rule = struct
Deco.edges = List.fold_left
(fun acc -> function
| (Command.ADD_EDGE (src_cn,tar_cn,edge),loc) ->
- (find src_cn (matching, created_nodes), Edge.as_label edge, find tar_cn (matching, created_nodes)) :: acc
+ (find src_cn (matching, created_nodes), edge, find tar_cn (matching, created_nodes)) :: acc
| _ -> acc
) [] commands
}
@@ -222,7 +222,7 @@ module Rule = struct
type partial = {
sub: matching;
unmatched_nodes: pid list;
- unmatched_edges: (pid * Edge.t * pid) list;
+ unmatched_edges: (pid * P_edge.t * pid) list;
already_matched_gids: gid list; (* to ensure injectivity *)
check: const list (* constraints to verify at the end of the matching *)
}
@@ -233,9 +233,9 @@ module Rule = struct
*)
let init pattern =
- let roots = Graph.roots pattern.graph in
+ let roots = P_graph.roots pattern.graph in
- let node_list = IntMap.fold (fun pid _ acc -> pid::acc) pattern.graph.Graph.map [] in
+ let node_list = Pid_map.fold (fun pid _ acc -> pid::acc) pattern.graph [] in
(* put all roots in the front of the list to speed up the algo *)
let sorted_node_list =
@@ -254,28 +254,29 @@ module Rule = struct
let fullfill graph matching = function
| No_out (pid,edge) ->
- let gid = IntMap.find pid matching.n_match in
- Graph.edge_out graph gid edge
+ let gid = Pid_map.find pid matching.n_match in
+ G_graph.edge_out graph gid edge
| No_in (pid,edge) ->
- let gid = IntMap.find pid matching.n_match in
- IntMap.exists
+ let gid = Pid_map.find pid matching.n_match in
+ Gid_map.exists
(fun _ node ->
- List.exists (fun e -> Edge.compatible edge e) (Massoc.assoc gid node.Node.next)
- ) graph.Graph.map
+ List.exists (fun e -> P_edge.compatible edge e) (Massoc.assoc gid (G_node.get_next node))
+ ) graph.G_graph.map
| Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
- let gnode1 = IntMap.find (IntMap.find pid1 matching.n_match) graph.Graph.map in
- let gnode2 = IntMap.find (IntMap.find pid2 matching.n_match) graph.Graph.map in
- (match (Feature_structure.get feat_name1 gnode1.Node.fs,
- Feature_structure.get feat_name2 gnode2.Node.fs) with
+ let gnode1 = Gid_map.find (Pid_map.find pid1 matching.n_match) graph.G_graph.map in
+ let gnode2 = Gid_map.find (Pid_map.find pid2 matching.n_match) graph.G_graph.map in
+ (match (Feature_structure.get feat_name1 (G_node.get_fs gnode1),
+ Feature_structure.get feat_name2 (G_node.get_fs gnode2)
+ ) with
| Some fv1, Some fv2 when fv1 = fv2 -> true
| _ -> false)
| Filter (pid, fs) ->
- let gid = IntMap.find pid matching.n_match in
- let gnode = IntMap.find gid graph.Graph.map in
- Feature_structure.filter fs gnode.Node.fs
+ let gid = Pid_map.find pid matching.n_match in
+ let gnode = Gid_map.find gid graph.G_graph.map in
+ Feature_structure.filter fs (G_node.get_fs gnode)
(* returns all extension of the partial input matching *)
- let rec extend_matching (positive,neg) (graph:Graph.t) (partial:partial) =
+ let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
match (partial.unmatched_edges, partial.unmatched_nodes) with
| [], [] ->
(* (\* DEBUG *\) Printf.printf "==<1>==\n%!"; *)
@@ -286,17 +287,17 @@ module Rule = struct
begin
try (* is the tar already found in the matching ? *)
let new_partials =
- let src_gid = IntMap.find src_pid partial.sub.n_match in
- let tar_gid = IntMap.find tar_pid partial.sub.n_match in
- let src_gnode = Graph.find src_gid graph in
- let g_edges = Massoc.assoc tar_gid src_gnode.Node.next in
+ let src_gid = Pid_map.find src_pid partial.sub.n_match in
+ let tar_gid = Pid_map.find tar_pid partial.sub.n_match in
+ let src_gnode = G_graph.find src_gid graph in
+ let g_edges = Massoc.assoc tar_gid (G_node.get_next src_gnode) in
- match Edge.match_list p_edge g_edges with
- | Edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
+ match P_edge.match_list p_edge g_edges with
+ | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
[]
- | Edge.Ok label -> (* at least an edge in the graph fits the p_edge "constraint" -> go on *)
+ | P_edge.Ok label -> (* at least an edge in the graph fits the p_edge "constraint" -> go on *)
[ {partial with unmatched_edges = tail_ue; sub = a_match_add (src_gid,label,tar_gid) partial.sub} ]
- | Edge.Binds (id,labels) -> (* n edges in the graph match the identified p_edge -> make copies of the [k] matchings (and returns n*k matchings) *)
+ | P_edge.Binds (id,labels) -> (* n edges in the graph match the identified p_edge -> make copies of the [k] matchings (and returns n*k matchings) *)
List.map
(fun label ->
{partial with sub = e_match_add (id,(src_gid,label,tar_gid)) partial.sub; unmatched_edges = tail_ue }
@@ -304,19 +305,19 @@ module Rule = struct
in List_.flat_map (extend_matching (positive,neg) graph) new_partials
with Not_found -> (* p_edge goes to an unmatched node *)
let candidates = (* candidates (of type (gid, matching)) for m(tar_pid) = gid) with new partial matching m *)
- let src_gid = IntMap.find src_pid partial.sub.n_match in
- let src_gnode = Graph.find src_gid graph in
+ let src_gid = Pid_map.find src_pid partial.sub.n_match in
+ let src_gnode = G_graph.find src_gid graph in
Massoc.fold_left
(fun acc gid_next g_edge ->
- match Edge.match_ p_edge g_edge with
- | Edge.Fail -> (* g_edge does not fit, no new candidate *)
+ match P_edge.match_ p_edge g_edge with
+ | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
acc
- | Edge.Ok label -> (* g_edge fits with the same matching *)
+ | P_edge.Ok label -> (* g_edge fits with the same matching *)
(gid_next, a_match_add (src_gid, label, gid_next) partial.sub) :: acc
- | Edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
+ | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
(gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
- | _ -> Error.bug "Edge.match_ must return exactly one label"
- ) [] src_gnode.Node.next in
+ | _ -> Error.bug "P_edge.match_ must return exactly one label"
+ ) [] (G_node.get_next src_gnode) in
List_.flat_map
(fun (gid_next, matching) ->
extend_matching_from (positive,neg) graph tar_pid gid_next
@@ -324,34 +325,34 @@ module Rule = struct
) candidates
end
| [], pid :: _ ->
- IntMap.fold
+ Gid_map.fold
(fun gid _ acc ->
(extend_matching_from (positive,neg) graph pid gid partial) @ acc
- ) graph.Graph.map []
+ ) graph.G_graph.map []
- and extend_matching_from (positive,neg) (graph:Graph.t) pid gid partial =
+ and extend_matching_from (positive,neg) (graph:G_graph.t) pid gid partial =
if List.mem gid partial.already_matched_gids
then [] (* the required association pid -> gid is not injective *)
else
let p_node =
if pid >= 0
- then try Graph.find pid positive with Not_found -> failwith "POS"
- else try Graph.find pid neg with Not_found -> failwith "NEG" in
- let g_node = try Graph.find gid graph with Not_found -> failwith "INS" in
- if not (Node.is_a p_node g_node)
+ then try P_graph.find pid positive with Not_found -> failwith "POS"
+ else try P_graph.find pid neg with Not_found -> failwith "NEG" in
+ let g_node = try G_graph.find gid graph with Not_found -> failwith "INS" in
+ if not (P_node.is_a p_node g_node)
then [] (* the nodes don't match *)
else
(* add all out-edges from pid in pattern *)
let new_unmatched_edges =
Massoc.fold_left
(fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
- ) partial.unmatched_edges p_node.Node.next in
+ ) partial.unmatched_edges (P_node.get_next p_node) in
let new_partial = { partial with
unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> failwith "List_.rm");
unmatched_edges = new_unmatched_edges;
already_matched_gids = gid :: partial.already_matched_gids;
- sub = {partial.sub with n_match = IntMap.add pid gid partial.sub.n_match};
+ sub = {partial.sub with n_match = Pid_map.add pid gid partial.sub.n_match};
} in
extend_matching (positive,neg) graph new_partial
@@ -369,7 +370,7 @@ module Rule = struct
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
begin
- match Graph.add_edge instance.Instance.graph src_gid edge tar_gid with
+ match G_graph.add_edge instance.Instance.graph src_gid edge tar_gid with
| Some new_graph ->
(
{instance with
@@ -379,7 +380,7 @@ module Rule = struct
created_nodes
)
| None ->
- Error.run "ADD_EDGE: the edge '%s' already exists %s" (Edge.to_string edge) (Loc.to_string loc)
+ Error.run "ADD_EDGE: the edge '%s' already exists %s" (G_edge.to_string edge) (Loc.to_string loc)
end
| Command.DEL_EDGE_EXPL (src_cn,tar_cn,edge) ->
@@ -387,20 +388,19 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
- Instance.graph = Graph.del_edge loc instance.Instance.graph src_gid edge tar_gid;
+ Instance.graph = G_graph.del_edge loc instance.Instance.graph src_gid edge tar_gid;
commands = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.commands
},
created_nodes
)
| Command.DEL_EDGE_NAME edge_ident ->
- let (src_gid,label,tar_gid) =
+ 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
- let edge = Edge.of_label label in
(
{instance with
- Instance.graph = Graph.del_edge ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
+ Instance.graph = G_graph.del_edge ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
commands = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.commands
},
created_nodes
@@ -410,7 +410,7 @@ module Rule = struct
let node_gid = node_find node_cn in
(
{instance with
- Instance.graph = Graph.del_node instance.Instance.graph node_gid;
+ Instance.graph = G_graph.del_node instance.Instance.graph node_gid;
commands = List_.sort_insert (Command.H_DEL_NODE node_gid) instance.Instance.commands
},
created_nodes
@@ -419,7 +419,7 @@ module Rule = struct
| Command.MERGE_NODE (src_cn, tar_cn) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
- (match Graph.merge_node loc instance.Instance.graph src_gid tar_gid with
+ (match G_graph.merge_node loc instance.Instance.graph src_gid tar_gid with
| Some new_graph ->
(
{instance with
@@ -435,11 +435,11 @@ module Rule = struct
let tar_gid = node_find tar_cn in
let rule_items = List.map
(function
- | Command.Feat (cnode, feat_name) -> Graph.Feat (node_find cnode, feat_name)
- | Command.String s -> Graph.String s
+ | Command.Feat (cnode, feat_name) -> G_graph.Feat (node_find cnode, feat_name)
+ | Command.String s -> G_graph.String s
) item_list in
let (new_graph, new_feature_value) =
- Graph.update_feat instance.Instance.graph tar_gid tar_feat_name rule_items in
+ G_graph.update_feat instance.Instance.graph tar_gid tar_feat_name rule_items in
(
{instance with
Instance.graph = new_graph;
@@ -454,15 +454,15 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
- Instance.graph = Graph.del_feat instance.Instance.graph tar_gid feat_name;
+ Instance.graph = G_graph.del_feat instance.Instance.graph tar_gid feat_name;
commands = List_.sort_insert (Command.H_DEL_FEAT (tar_gid,feat_name)) instance.Instance.commands
},
created_nodes
)
| Command.NEW_NEIGHBOUR (created_name,edge,base_pid) ->
- let base_gid = IntMap.find base_pid matching.n_match in
- let (new_gid,new_graph) = Graph.add_neighbour loc instance.Instance.graph base_gid edge in
+ let base_gid = Pid_map.find base_pid matching.n_match in
+ let (new_gid,new_graph) = G_graph.add_neighbour loc instance.Instance.graph base_gid edge in
(
{instance with
Instance.graph = new_graph;
@@ -476,7 +476,7 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
- Instance.graph = Graph.shift_in loc instance.Instance.graph src_gid tar_gid;
+ Instance.graph = G_graph.shift_in loc instance.Instance.graph src_gid tar_gid;
commands = List_.sort_insert (Command.H_SHIFT_IN (src_gid,tar_gid)) instance.Instance.commands
},
created_nodes
@@ -487,7 +487,7 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
- Instance.graph = Graph.shift_out loc instance.Instance.graph src_gid tar_gid;
+ Instance.graph = G_graph.shift_out loc instance.Instance.graph src_gid tar_gid;
commands = List_.sort_insert (Command.H_SHIFT_OUT (src_gid,tar_gid)) instance.Instance.commands
},
created_nodes
@@ -498,15 +498,12 @@ module Rule = struct
let tar_gid = node_find tar_cn in
(
{instance with
- Instance.graph = Graph.shift_edges loc instance.Instance.graph src_gid tar_gid;
+ Instance.graph = G_graph.shift_edges loc instance.Instance.graph src_gid tar_gid;
commands = List_.sort_insert (Command.H_SHIFT_EDGE (src_gid,tar_gid)) instance.Instance.commands
},
created_nodes
)
-
-(* (\* DEBUG *\)let cpt = ref 0 *)
-
(** [apply_rule instance matching rule] returns a new instance after the application of the rule
[Command_execution_fail] is raised if some merge unification fails
*)
@@ -528,24 +525,6 @@ module Rule = struct
let rule_app = {Grew_types.rule_name = rule.name; up = up_deco matching; down = down_deco (matching,created_nodes) rule.commands } in
- (* (\* DEBUG *\) let up_dot = Graph.to_dot ~deco:rule_app.Grew_types.up instance.Instance.graph in *)
- (* (\* DEBUG *\) let _ = File.write up_dot (Printf.sprintf "dot_%d_a.dot" !cpt) in *)
- (* (\* DEBUG *\) let _ = Sys.command (Printf.sprintf "dot -Tpng -o dot_%d_a.png dot_%d_a.dot" !cpt !cpt) in *)
-
- (* (\* DEBUG *\) let up_dep = Graph.to_dep ~deco:rule_app.Grew_types.up instance.Instance.graph in *)
- (* (\* DEBUG *\) let _ = File.write up_dep (Printf.sprintf "dep_%d_a.dep" !cpt) in *)
- (* (\* DEBUG *\) let _ = Sys.command (Printf.sprintf "dep2pict -png -o dep_%d_a.png -dep dep_%d_a.dep" !cpt !cpt) in *)
-
- (* (\* DEBUG *\) let down_dot = Graph.to_dot ~deco:rule_app.Grew_types.down new_instance.Instance.graph in *)
- (* (\* DEBUG *\) let _ = File.write down_dot (Printf.sprintf "dot_%d_b.dot" !cpt) in *)
- (* (\* DEBUG *\) let _ = Sys.command (Printf.sprintf "dot -Tpng -o dot_%d_b.png dot_%d_b.dot" !cpt !cpt) in *)
-
- (* (\* DEBUG *\) let down_dep = Graph.to_dep ~deco:rule_app.Grew_types.down new_instance.Instance.graph in *)
- (* (\* DEBUG *\) let _ = File.write down_dep (Printf.sprintf "dep_%d_b.dep" !cpt) in *)
- (* (\* DEBUG *\) let _ = Sys.command (Printf.sprintf "dep2pict -png -o dep_%d_b.png -dep dep_%d_b.dep" !cpt !cpt) in *)
-
- (* (\* DEBUG *\) incr cpt; *)
-
{new_instance with
Instance.rules = rule.name :: new_instance.Instance.rules;
big_step = match new_instance.Instance.big_step with
@@ -557,21 +536,17 @@ module Rule = struct
let update_partial pos_graph without (sub, already_matched_gids) =
let neg_graph = without.graph in
- let unmatched_nodes = IntMap.fold (fun pid _ acc -> if pid < 0 then pid::acc else acc) neg_graph.Graph.map [] in
+ let unmatched_nodes = Pid_map.fold (fun pid _ acc -> if pid < 0 then pid::acc else acc) neg_graph [] in
let unmatched_edges =
- IntMap.fold
+ Pid_map.fold
(fun pid node acc ->
if pid < 0
then acc
else
Massoc.fold_left
(fun acc2 pid_next p_edge -> (pid, p_edge, pid_next) :: acc2)
- acc node.Node.next
- ) neg_graph.Graph.map [] in
-
-(* Printf.printf "XXX -> unmatched_nodes: %d\n" (List.length unmatched_nodes); *)
-(* Printf.printf "XXX -> unmatched_edges: %d\n" (List.length unmatched_edges); *)
-
+ acc (P_node.get_next node)
+ ) neg_graph [] in
{
sub = sub;
unmatched_nodes = unmatched_nodes;
@@ -596,7 +571,7 @@ module Rule = struct
(* get the list of partial matching for positive part of the pattern *)
let matching_list =
extend_matching
- (pos_graph,Graph.empty)
+ (pos_graph,P_graph.empty)
instance.Instance.graph
(init rule.pos) in
@@ -627,7 +602,7 @@ module Rule = struct
(* get the list of partial matching for positive part of the pattern *)
let matching_list =
extend_matching
- (pos_graph,Graph.empty)
+ (pos_graph,P_graph.empty)
instance.Instance.graph
(init rule.pos) in
@@ -649,7 +624,7 @@ module Rule = struct
(** filter nfs being equal *)
let rec filter_equal_nfs nfs =
Instance_set.fold (fun nf acc ->
- if Instance_set.exists (fun e -> Graph.equals e.Instance.graph nf.Instance.graph) acc
+ if Instance_set.exists (fun e -> G_graph.equals e.Instance.graph nf.Instance.graph) acc
then (printf "two normal equal normal forms"; acc)
else Instance_set.add nf acc)
nfs Instance_set.empty
diff --git a/src/grew_rule.mli b/src/grew_rule.mli
index 0a2d962dad4df9a9d01e791ddaa03e606b2c9120..1b45af2593867637ccb5586e7190493f6fac0a61 100644
--- a/src/grew_rule.mli
+++ b/src/grew_rule.mli
@@ -7,7 +7,7 @@ open Grew_ast
module Instance : sig
type t = {
- graph: Graph.t;
+ graph: G_graph.t;
commands: Command.h list;
rules: string list;
big_step: Grew_types.big_step option;
@@ -21,8 +21,8 @@ module Instance : sig
val rev_steps: t -> t
val clear: t -> t
- val from_graph: Graph.t -> t
- val get_graph: t -> Graph.t
+ val from_graph: G_graph.t -> t
+ val get_graph: t -> G_graph.t
IFDEF DEP2PICT THEN
(* [save_dep_png base t] writes a file "base.png" with the dep representation of [t] *)
diff --git a/src/grew_types.ml b/src/grew_types.ml
index fdc5f7a71a2d7ea41c13f322c05c11983896c5d5..e125689ef9455d15db041160660e349994e27ed6 100644
--- a/src/grew_types.ml
+++ b/src/grew_types.ml
@@ -1,6 +1,6 @@
open Grew_graph
-type graph = Graph.t
+type graph = G_graph.t
type deco = Deco.t
type module_name = string
@@ -14,16 +14,16 @@ type rule_app = {
(* the main type for display the result of a rewriting *)
type rew_display =
| Empty (* pour les besoin du dev *)
- | Leaf of Graph.t
- | Local_normal_form of Graph.t * module_name * rew_display
- | Node of Graph.t * module_name * (big_step * rew_display) list
+ | Leaf of G_graph.t
+ | Local_normal_form of G_graph.t * module_name * rew_display
+ | Node of G_graph.t * module_name * (big_step * rew_display) list
(* the type for big edges which correspond to a module *)
and big_step = {
first: rule_app;
- small_step: (Graph.t * rule_app) list;
+ small_step: (G_graph.t * rule_app) list;
}
-let to_dot_graph ?main_feat ?(deco=Deco.empty) graph = Graph.to_dot ?main_feat graph ~deco
-let to_dep_graph ?main_feat ?(deco=Deco.empty) graph = Graph.to_dep ?main_feat ~deco graph
-let to_gr_graph graph = Graph.to_gr graph
+let to_dot_graph ?main_feat ?(deco=Deco.empty) graph = G_graph.to_dot ?main_feat graph ~deco
+let to_dep_graph ?main_feat ?(deco=Deco.empty) graph = G_graph.to_dep ?main_feat ~deco graph
+let to_gr_graph graph = G_graph.to_gr graph
diff --git a/src/grew_types.mli b/src/grew_types.mli
index bc901ad229653b3fcd4e0f649296824d9873342e..d985b259e23fbc04b8107386295f02f956ddb3a7 100644
--- a/src/grew_types.mli
+++ b/src/grew_types.mli
@@ -3,7 +3,7 @@
open Grew_graph
(**/**)
-type graph = Graph.t
+type graph = G_graph.t
type deco = Deco.t
(**/**)
diff --git a/src/grew_utils.ml b/src/grew_utils.ml
index b5718e393b4ed801b9b3907e452e1f143b35f6ef..74cb00570e1ee4603ccee9eb4282f3fcaf2c2f27 100644
--- a/src/grew_utils.ml
+++ b/src/grew_utils.ml
@@ -6,9 +6,16 @@ module StringMap = Map.Make (String)
module IntSet = Set.Make (struct type t = int let compare = Pervasives.compare end)
-module IntMap =
+module IntMap = Map.Make (struct type t = int let compare = Pervasives.compare end)
+
+module Pid = struct
+ type t = int
+ let compare = Pervasives.compare
+end
+
+module Pid_map =
struct
- include Map.Make (struct type t = int let compare = Pervasives.compare end)
+ include Map.Make (Pid)
(** returns the image of a map [m]*)
exception True
@@ -172,6 +179,12 @@ module List_ = struct
| [] -> ""
| h::t -> List.fold_left (fun acc elt -> acc ^ sep ^ (string_of_item elt)) (string_of_item h) t
+ let rec sort_mem elt = function
+ | [] -> false
+ | h::t when elt<h -> false
+ | h::t when elt>h -> sort_mem elt t
+ | _ -> (* elt=h *) true
+
let rec sort_insert elt = function
| [] -> [elt]
| h::t when elt<h -> elt::h::t
diff --git a/src/grew_utils.mli b/src/grew_utils.mli
index 6030b3e2c7b32c8841efd4f2f1ed6638f03293e8..5b24918a750a0ddb20c8a2dd3249f82866e57f9c 100644
--- a/src/grew_utils.mli
+++ b/src/grew_utils.mli
@@ -1,7 +1,10 @@
module IntSet : Set.S with type elt = int
+module IntMap : Map.S with type key = int
-module IntMap : sig
+module Pid : sig type t = int end
+
+module Pid_map : sig
include Map.S with type key = int
exception MatchNotInjective
val exists: (key -> 'a -> bool) -> 'a t -> bool
@@ -55,6 +58,8 @@ module List_: sig
val mapi: (int -> 'a -> 'b) -> 'a list -> 'b list
+ val sort_mem: 'a -> 'a list -> bool
+
(* Insert an element in a sorted list. *)
val sort_insert: 'a -> 'a list -> 'a list