Commit 4f225d38 authored by bguillaum's avatar bguillaum

change implementation of nodes precedences

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8962 7838e531-6607-4d57-9587-6c381814729c
parent 1d0c92fc
......@@ -64,15 +64,12 @@ module P_edge = struct
| Binds of string * Label.t list
let match_ label_domain pattern_edge graph_label =
if Label.is_succ graph_label
then Fail
else
match pattern_edge with
| {id = Some i; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Ok graph_label
| {id = Some i; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Ok graph_label
| _ -> Fail
match pattern_edge with
| {id = Some i; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Ok graph_label
| {id = Some i; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Ok graph_label
| _ -> Fail
let match_list label_domain pattern_edge graph_edge_list =
match pattern_edge with
......
......@@ -349,19 +349,17 @@ module G_graph = struct
let gtable = (Array.of_list (List.map (fun line -> line.Conll.id) sorted_lines), string_of_int) in
let (map_without_edges,_) =
List_.foldi_left
(fun i (acc, prev_opt) line ->
let loc = Loc.file_opt_line conll.Conll.file line.Conll.line_num in
let with_new_node = Gid_map.add (Gid.Old i) (G_node.of_conll domain ~loc line) acc in
match prev_opt with
| None -> (with_new_node, Some (Gid.Old i))
| Some prev_id ->
match map_add_edge with_new_node prev_id Label.succ (Gid.Old i) with
| Some m -> (m, Some (Gid.Old i))
| None -> Error.bug "[GRS] [Graph.of_conll] fail to add __SUCC__"
)
(Gid_map.empty, None) sorted_lines in
let rec loop index prec = function
| [] -> Gid_map.empty
| [last] ->
let loc = Loc.file_opt_line conll.Conll.file last.Conll.line_num in
Gid_map.add (Gid.Old index) (G_node.of_conll domain ~loc ?prec last) Gid_map.empty
| line::tail ->
let loc = Loc.file_opt_line conll.Conll.file line.Conll.line_num in
Gid_map.add (Gid.Old index) (G_node.of_conll domain ~loc ?prec ~succ:(Gid.Old (index+1)) line)
(loop (index+1) (Some (Gid.Old index)) tail) in
let map_without_edges = loop 0 None sorted_lines in
let map_with_edges =
List.fold_left
......@@ -730,6 +728,21 @@ module G_graph = struct
(* edges *)
bprintf buff "[EDGES] { \n";
List.iter
(fun (id, node) ->
begin
match G_node.get_prec node with
| None -> ()
| Some p -> bprintf buff "N_%s -> N_%s { label=\"__PREC__\"; bottom; style=dot}\n" (Gid.to_string id) (Gid.to_string p)
end;
begin
match G_node.get_succ node with
| None -> ()
| Some s -> bprintf buff "N_%s -> N_%s { label=\"__SUCC__\"; bottom; style=dot}\n" (Gid.to_string id) (Gid.to_string s)
end
) snodes;
Gid_map.iter
(fun gid elt ->
Massoc_gid.iter
......
......@@ -23,6 +23,8 @@ module G_node = struct
type t = {
fs: G_fs.t;
next: G_edge.t Massoc_gid.t;
succ: Gid.t option;
prec: Gid.t option;
position: float;
conll_root: bool;
}
......@@ -36,7 +38,10 @@ module G_node = struct
let get_position t = t.position
let set_position position t = { t with position }
let empty = { fs = G_fs.empty; next = Massoc_gid.empty; position = -1.; conll_root=false }
let get_prec t = t.prec
let get_succ t = t.succ
let empty = { fs = G_fs.empty; next = Massoc_gid.empty; succ = None; prec = None; position = -1.; conll_root=false }
let is_conll_root t = t.conll_root
......@@ -64,10 +69,10 @@ module G_node = struct
| (None, None) -> Error.bug "Cannot build a node without position" in
(ast_node.Ast.node_id, { empty with fs; position })
let of_conll ?loc domain line =
let of_conll ?loc ?prec ?succ domain line =
if line = Conll.root
then { empty with conll_root=true }
else { empty with fs = G_fs.of_conll ?loc domain line; position = float line.Conll.id }
else { empty with fs = G_fs.of_conll ?loc domain line; position = float line.Conll.id; prec; succ }
let remove (id_tar : Gid.t) label t = {t with next = Massoc_gid.remove id_tar label t.next}
......
......@@ -28,6 +28,9 @@ module G_node: sig
val get_fs: t -> G_fs.t
val get_next: t -> G_edge.t Massoc_gid.t
val get_succ: t -> Gid.t option
val get_prec: t -> Gid.t option
val set_fs: G_fs.t -> t -> t
val set_position: float -> t -> t
val set_next: G_edge.t Massoc_gid.t -> t -> t
......@@ -45,7 +48,7 @@ module G_node: sig
val add_edge: G_edge.t -> Gid.t -> t -> t option
val build: Domain.t -> ?def_position: float -> Ast.node -> (Id.name * t)
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.line -> t
val of_conll: ?loc:Loc.t -> ?prec:Gid.t -> ?succ:Gid.t -> Domain.t -> Conll.line -> t
val get_position: t -> float
......
......@@ -583,10 +583,8 @@ module Rule = struct
| Prec (pid1, pid2) ->
let gid1 = Pid_map.find pid1 matching.n_match in
let gid2 = Pid_map.find pid2 matching.n_match in
let gnode1 = G_graph.find gid1 graph in
let edges_1_to_2 = Massoc_gid.assoc gid2 (G_node.get_next gnode1) in
if List.exists (fun l -> Label.is_succ l) edges_1_to_2
if G_node.get_succ gnode1 = Some gid2
then matching
else raise Fail
| Lprec (pid1, pid2) ->
......
......@@ -294,11 +294,6 @@ module Label = struct
| Global of int (* globally defined labels: their names are in the domain *)
| Local of int (* locally defined labels: names array should be provided! UNTESTED *)
| Pattern of string
| Succ
let succ = Succ
let is_succ = function Succ -> true | _ -> false
let match_ ((table,_),_) p_label g_label = match (p_label, g_label) with
| (Global p, Global g) when p=g -> true
......@@ -313,7 +308,6 @@ module Label = struct
| Global i -> table.(i)
| Local i -> fst locals.(i)
| Pattern s -> s
| Succ -> "__SUCC__"
let to_int = function
| Global i -> Some i
......@@ -323,7 +317,6 @@ module Label = struct
| Global i -> styles.(i)
| Local i -> Log.warning "Style of locally defined labels is not implemented"; Label_domain.default
| Pattern _ -> Label_domain.default
| Succ -> { Label_domain.default with Label_domain.text = "__SUCC__"; color= Some "red"; bottom=true; line=Label_domain.Dot }
let to_dep (label_domain,_) ?(deco=false) t =
let style = get_style label_domain t in
......
......@@ -121,10 +121,6 @@ end
module Label : sig
type t
val succ: t (* built-in label for succ relation *)
val is_succ: t -> bool
(** [match_ dom p_label g_label] returns [true] iff [g_label]
is a global label matching either constant p_label or patten p_label *)
val match_: Domain.t -> t -> t -> bool
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment