Commit 971d5500 authored by bguillaum's avatar bguillaum

move from 'int' to 'Gid.t'/'Pid.t'... it compiles

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7419 7838e531-6607-4d57-9587-6c381814729c
parent c00c6e36
*.cmo
*.cmi
*.o
*.cmx
*.annot
*.a
*.cma
*.cmxa
Makefile
confdefs.h
config.log
config.status
# file generated by the Makefile !
libgrew.mli
......@@ -7,8 +7,8 @@ open Grew_edge
open Grew_fs
module Command = struct
type pid = int (* the int in the pattern *)
type gid = int (* the int in the graph *)
type pid = Pid.t
type gid = Gid.t
type cnode = (* a command node is either: *)
| Pid of pid (* a node identified in the pattern *)
......
......@@ -3,8 +3,8 @@ open Grew_utils
open Grew_edge
module Command : sig
type pid = int (* the int in the pattern *)
type gid = int (* the int in the graph *)
type pid = Pid.t
type gid = Gid.t
type cnode = (* a command node is either: *)
| Pid of pid (* a node identified in the pattern *)
......
......@@ -10,16 +10,26 @@ open Grew_command
(* ================================================================================ *)
module Deco = struct
module P_deco = struct
type t =
{ nodes: int list;
edges: (int * G_edge.t * int) list;
{ nodes: Pid.t list;
edges: (Pid.t * P_edge.t * Pid.t) list;
}
let empty = {nodes=[]; edges=[]}
end
(* ================================================================================ *)
(* ================================================================================ *)
module G_deco = struct
type t =
{ nodes: Gid.t list;
edges: (Gid.t * G_edge.t * Gid.t) list;
}
let empty = {nodes=[]; edges=[]}
end
(* ================================================================================ *)
(* ================================================================================ *)
module P_graph = struct
......@@ -29,19 +39,19 @@ module P_graph = struct
let find = Pid_map.find
let map_add_edge map id_src label id_tar =
let node_src =
let node_src =
(* Not found can be raised when adding an edge from pos to neg *)
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 table (ast_node, loc) =
let build_filter table (ast_node, loc) =
let pid = Id.build ~loc ast_node.Ast.node_id table in
let fs = P_fs.build ast_node.Ast.fs in
(pid, fs)
let build ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
let build ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
(* let (named_nodes, constraints) = *)
(* let rec loop already_bound = function *)
(* | [] -> ([],[]) *)
......@@ -58,7 +68,7 @@ module P_graph = struct
(n, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) h) :: t
| h::t -> h :: (insert (ast_node, loc) t) in
let (named_nodes : (Id.name * P_node.t) list) =
let (named_nodes : (Id.name * P_node.t) list) =
let rec loop = function
| [] -> []
| ast_node :: tail ->
......@@ -75,10 +85,10 @@ module P_graph = struct
(* table contains the sorted list of node ids *)
let table = Array.of_list sorted_ids in
(* the nodes, in the same order *)
(* the nodes, in the same order *)
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 : t) =
List.fold_left
(fun acc (ast_edge, loc) ->
......@@ -87,7 +97,7 @@ module P_graph = struct
let edge = P_edge.build ~locals (ast_edge, loc) in
(match map_add_edge acc i1 edge i2 with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(P_edge.to_string edge)
(Loc.to_string loc)
)
......@@ -96,19 +106,19 @@ module P_graph = struct
(* a type for extension of graph: a former graph exists:
(* 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 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_extension ?(locals=[||]) old_table full_node_list full_edge_list =
let build_extension ?(locals=[||]) old_table full_node_list full_edge_list =
let built_nodes = List.map P_node.build full_node_list in
let (old_nodes, new_nodes) =
List.partition
let (old_nodes, new_nodes) =
List.partition
(function (id,_) when Array_.dicho_mem id old_table -> true | _ -> false)
built_nodes in
......@@ -118,53 +128,53 @@ module P_graph = struct
(* table contains the sorted list of node ids *)
let new_table = Array.of_list new_sorted_ids in
(* the nodes, in the same order stored with index -1, -2, ... -N *)
let ext_map_without_edges =
List_.foldi_left
(fun i acc elt -> Pid_map.add (-i-1) elt acc)
Pid_map.empty
(* the nodes, in the same order stored with index -1, -2, ... -N *)
let ext_map_without_edges =
List_.foldi_left
(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) -> Pid_map.add (Array_.dicho_find id old_table) node acc)
Pid_map.empty
let old_map_without_edges =
List.fold_left
(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 =
let ext_map_with_all_edges =
List.fold_left
(fun acc (ast_edge, loc) ->
let i1 =
match Id.build_opt ast_edge.Ast.src old_table
let i1 =
match Id.build_opt ast_edge.Ast.src old_table
with Some i -> i | None -> -1-(Id.build ~loc ast_edge.Ast.src new_table) in
let i2 =
match Id.build_opt ast_edge.Ast.tar old_table
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 = 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_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)
(* ---------------------------------------------------------------------------------------------------- *)
(* Topology functions *)
(* ---------------------------------------------------------------------------------------------------- *)
(* [tree_and_roots t] returns:
- a boolean which is true iff the each node has at most one in-edge
- the list of "roots" (i.e. nodes without in-edge *)
let tree_and_roots graph =
let tree_prop = ref true in
let not_root =
Pid_map.fold
(fun _ node acc ->
Massoc.fold_left
Pid_map.fold
(fun _ node acc ->
Massoc.fold_left
(fun acc2 tar _ ->
if !tree_prop
then
then
if IntSet.mem tar acc2
then (tree_prop := false; acc2)
else IntSet.add tar acc2
......@@ -173,13 +183,13 @@ module P_graph = struct
) graph IntSet.empty in
let roots =
Pid_map.fold
(fun id _ acc ->
Pid_map.fold
(fun id _ acc ->
if IntSet.mem id not_root
then acc
then acc
else id::acc
) graph [] in
(!tree_prop, roots)
let roots graph = snd (tree_and_roots graph)
......@@ -204,16 +214,16 @@ module G_graph = struct
| String of string
let map_add_edge map id_src label id_tar =
let node_src =
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 ?(locals=[||]) full_node_list full_edge_list =
let build ?(locals=[||]) full_node_list full_edge_list =
let named_nodes =
let named_nodes =
let rec loop already_bound = function
| [] -> []
| (ast_node, loc) :: tail ->
......@@ -228,53 +238,53 @@ module G_graph = struct
(* 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
(* the nodes, in the same order *)
let map_without_edges = List_.foldi_left (fun i acc elt -> Gid_map.add (Gid.Old 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
(match map_add_edge acc (Gid.Old i1) edge (Gid.Old i2) with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
| None -> Error.build "[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}
let of_conll ?loc lines =
let nodes =
let nodes =
List.fold_left
(fun acc line ->
Gid_map.add line.Conll.num (G_node.of_conll line) acc)
(fun acc line ->
Gid_map.add (Gid.Old line.Conll.num) (G_node.of_conll line) acc)
Gid_map.empty lines in
let nodes_with_edges =
let nodes_with_edges =
List.fold_left
(fun acc line ->
(* add line number information in loc *)
let loc = Loc.opt_set_line line.Conll.line_num loc in
if line.Conll.gov=0
then acc
else
let gov_node =
try Gid_map.find line.Conll.gov acc
with Not_found ->
else
let gov_node =
try Gid_map.find (Gid.Old line.Conll.gov) acc
with Not_found ->
Error.build ?loc "[G_graph.of_conll] the line refers to unknown gov %d" line.Conll.gov in
match G_node.add_edge (G_edge.make ?loc line.Conll.dep_lab) line.Conll.num gov_node with
match G_node.add_edge (G_edge.make ?loc line.Conll.dep_lab) (Gid.Old line.Conll.num) gov_node with
| None -> acc
| Some new_node -> Gid_map.add line.Conll.gov new_node acc
| Some new_node -> Gid_map.add (Gid.Old line.Conll.gov) new_node acc
) nodes lines in
{map = nodes_with_edges; lub=1+(Gid_map.fold (fun _ _ acc -> acc+1) nodes_with_edges 0)}
......@@ -287,7 +297,7 @@ module G_graph = struct
(* [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}
......@@ -296,59 +306,62 @@ module G_graph = struct
(* 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 Gid_map.find id_src graph.map
with Not_found ->
let del_edge ?edge_ident loc graph id_src label id_tar =
let node_src =
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 =
try {graph with 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'" (G_edge.to_string label)
(* remove node i from graph, with all its incoming and outcoming edges *)
(* 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 =
Gid_map.fold
let del_node graph node_id =
let new_map =
Gid_map.fold
(fun id value acc ->
if id = node_id
if id = node_id
then acc
(* 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 label =
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 + ((Label.to_int label) * graph.lub) + node_id in
(* let index = graph.lub + ((Label.to_int label) * graph.lub) + node_id in *)
let index = match node_id with
| Gid.Old id -> Gid.New (id, Label.to_int label)
| Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
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 = Gid_map.find node_id graph.map in
(* put the new node on the right of its "parent" *)
let new_graph = {graph with map = Gid_map.add index (G_node.build_neighbour node) graph.map} in
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
(* move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
(* 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 = Gid_map.find tar_gid graph.map in
if Massoc.mem_key src_gid (G_node.get_next tar_node)
if Massoc_gid.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 =
let new_map =
Gid_map.mapi
(fun node_id node ->
match G_node.merge_key src_gid tar_gid node with
......@@ -358,21 +371,21 @@ module G_graph = struct
in {graph with map = new_map}
(* move all out-edges from id_src are moved to out-edges out off node id_tar *)
(* 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 = 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 (G_node.get_next src_node)
if Massoc_gid.mem_key tar_gid (G_node.get_next src_node)
then Error.run ~loc "[Graph.shift_out] dependency from src to tar";
let new_map =
let new_map =
Gid_map.mapi
(fun node_id node ->
if node_id = src_gid
then (* [src_id] becomes without out-edges *)
if node_id = src_gid
then (* [src_id] becomes without out-edges *)
G_node.rm_out_edges node
else if node_id = tar_gid
else if node_id = tar_gid
then
match G_node.shift_out src_node tar_node with
| Some n -> n
......@@ -381,24 +394,24 @@ module G_graph = struct
) 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 *)
(* 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 = 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 (G_node.get_next src_node)
if Massoc_gid.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 (G_node.get_next tar_node)
if Massoc_gid.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 =
let new_map =
Gid_map.mapi
(fun node_id node ->
if node_id = src_gid
then (* [src_id] becomes an isolated node *)
if node_id = src_gid
then (* [src_id] becomes an isolated node *)
G_node.rm_out_edges node
else if node_id = tar_gid
else if node_id = tar_gid
then
match G_node.shift_out src_node tar_node with
| Some n -> n
......@@ -416,16 +429,16 @@ module G_graph = struct
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 G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
| Some new_fs ->
| Some new_fs ->
let new_map =
Gid_map.add
tar_gid
tar_gid
(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
| None -> None
let set_feat ?loc graph node_id feat_name new_value =
let node = Gid_map.find node_id graph.map in
......@@ -448,33 +461,33 @@ module G_graph = struct
(set_feat ?loc graph tar_id tar_feat_name new_feature_value, 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 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 (* {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)
bprintf buff "N_%s %s;\n" (Gid.to_string 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
Massoc_gid.iter
(fun tar edge ->
bprintf buff "N_%s -[%s]-> N_%s;\n" (Gid.to_string id) (G_edge.to_string edge) (Gid.to_string tar)
) (G_node.get_next node)
) graph.map;
bprintf buff "}\n";
Buffer.contents buff
......@@ -495,14 +508,14 @@ module G_graph = struct
"_-_", "-";
"_", " ";
"' ", "'";
" ,", ",";
" .", ".";
" ,", ",";
" .", ".";
"( ", "(";
" )", ")";
"\\\"", "\"";
]
let to_dep ?main_feat ?(deco=Deco.empty) graph =
let to_dep ?main_feat ?(deco=G_deco.empty) graph =
let buff = Buffer.create 32 in
bprintf buff "[GRAPH] { opacity=0; scale = 200; fontname=\"Arial\"; }\n";
......@@ -512,30 +525,30 @@ module G_graph = struct
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 (G_fs.to_dep ?main_feat (G_node.get_fs node))
else bprintf buff
"N%d { %s }\n" id (G_fs.to_dep ?main_feat (G_node.get_fs node))
(fun (id, node) ->
if List.mem id deco.G_deco.nodes
then bprintf buff
"N_%s { %sforecolor=red; subcolor=red; }\n" (Gid.to_string id) (G_fs.to_dep ?main_feat (G_node.get_fs node))
else bprintf buff
"N_%s { %s }\n" (Gid.to_string id) (G_fs.to_dep ?main_feat (G_node.get_fs node))
) snodes;
bprintf buff "} \n";
bprintf buff "[EDGES] { \n";
Gid_map.iter
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)
Massoc_gid.iter
(fun tar g_edge ->
let deco = List.mem (gid,g_edge,tar) deco.G_deco.edges in
bprintf buff "N_%s -> N_%s %s\n" (Gid.to_string gid) (Gid.to_string 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 to_dot ?main_feat ?(deco=G_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";
......@@ -543,30 +556,30 @@ module G_graph = struct
(* list of the nodes *)
Gid_map.iter
(fun id node ->
bprintf buff " N%d [label=\"%s\", color=%s]\n"
id
(G_fs.to_dot ?main_feat (G_node.get_fs node))
(if List.mem id deco.Deco.nodes then "red" else "black")
bprintf buff " N_%s [label=\"%s\", color=%s]\n"
(Gid.to_string id)
(G_fs.to_dot ?main_feat (G_node.get_fs node))
(if List.mem id deco.G_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)
Massoc_gid.iter
(fun tar g_edge ->
let deco = List.mem (id,g_edge,tar) deco.G_deco.edges in
bprintf buff " N_%s -> N_%s%s\n" (Gid.to_string id) (Gid.to_string 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' = 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 p_edge =
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)
Massoc_gid.exists (fun _ e -> P_edge.compatible p_edge e) (G_node.get_next node)
end (* module G_graph *)
(* ================================================================================ *)
......@@ -5,14 +5,29 @@ open Grew_node
open Grew_utils
open Grew_command
module Deco: sig
type t =
{ nodes: int list;
edges: (int * Label.t * int) list;
(* ================================================================================ *)
module P_deco: sig
type t =
{ nodes: Pid.t list;
edges: (Pid.t * P_edge.t * Pid.t) list;
}
val empty:t
end
(* ================================================================================ *)