From 613ef276df95e248c55ec6911816ff7028d2b8b4 Mon Sep 17 00:00:00 2001 From: bguillaum Date: Fri, 13 May 2016 10:04:06 +0000 Subject: [PATCH] implement precedence with a __SUCC__ edge git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8960 7838e531-6607-4d57-9587-6c381814729c --- src/grew_edge.ml | 29 +++++++++++++++++------------ src/grew_graph.ml | 16 ++++++++++++---- src/grew_rule.ml | 15 +++++++++++---- src/grew_types.ml | 7 +++++++ src/grew_types.mli | 8 ++++++++ 5 files changed, 55 insertions(+), 20 deletions(-) diff --git a/src/grew_edge.ml b/src/grew_edge.ml index fd72c41..03d7d39 100644 --- a/src/grew_edge.ml +++ b/src/grew_edge.ml @@ -64,12 +64,15 @@ module P_edge = struct | Binds of string * Label.t list let match_ label_domain pattern_edge graph_label = - 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 + 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 let match_list label_domain pattern_edge graph_edge_list = match pattern_edge with @@ -78,12 +81,14 @@ module P_edge = struct | {id = None; u_label = Label_cst.Neg l} when List.exists (fun label -> not (Label.match_list label_domain l label)) graph_edge_list -> Ok (List.hd graph_edge_list) | {id = Some i; u_label = Label_cst.Pos l} -> - (match List.filter (fun label -> Label.match_list label_domain l label) graph_edge_list with - | [] -> Fail - | list -> Binds (i, list)) + ( match List.filter (fun label -> Label.match_list label_domain l label) graph_edge_list with + | [] -> Fail + | list -> Binds (i, list) + ) | {id = Some i; u_label = Label_cst.Neg l} -> - (match List.filter (fun label -> not (Label.match_list label_domain l label)) graph_edge_list with - | [] -> Fail - | list -> Binds (i, list)) + ( match List.filter (fun label -> not (Label.match_list label_domain l label)) graph_edge_list with + | [] -> Fail + | list -> Binds (i, list) + ) | _ -> Fail end (* module P_edge *) diff --git a/src/grew_graph.ml b/src/grew_graph.ml index 34bd87b..3971d4e 100644 --- a/src/grew_graph.ml +++ b/src/grew_graph.ml @@ -350,12 +350,20 @@ 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 = + let (map_without_edges,_) = List_.foldi_left - (fun i acc line -> + (fun i (acc, prev_opt) line -> let loc = Loc.file_opt_line conll.Conll.file line.Conll.line_num in - Gid_map.add (Gid.Old i) (G_node.of_conll domain ~loc line) acc) - Gid_map.empty sorted_lines 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 map_with_edges = List.fold_left (fun acc line -> diff --git a/src/grew_rule.ml b/src/grew_rule.ml index a033d19..bd5d8b0 100644 --- a/src/grew_rule.ml +++ b/src/grew_rule.ml @@ -587,11 +587,18 @@ 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 - failwith "TODO" + + 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 + then matching + else raise Fail | Lprec (pid1, pid2) -> - let gid1 = Pid_map.find pid1 matching.n_match in - let gid2 = Pid_map.find pid2 matching.n_match in - failwith "TODO" + let gnode1 = G_graph.find (Pid_map.find pid1 matching.n_match) graph in + let gnode2 = G_graph.find (Pid_map.find pid2 matching.n_match) graph in + if G_node.get_position gnode1 < G_node.get_position gnode2 + then matching + else raise Fail (* ---------------------------------------------------------------------- *) (* returns all extension of the partial input matching *) diff --git a/src/grew_types.ml b/src/grew_types.ml index 43a0509..636dee3 100644 --- a/src/grew_types.ml +++ b/src/grew_types.ml @@ -303,6 +303,11 @@ 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 @@ -317,6 +322,7 @@ 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 @@ -326,6 +332,7 @@ 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 diff --git a/src/grew_types.mli b/src/grew_types.mli index f04e70f..0faee0e 100644 --- a/src/grew_types.mli +++ b/src/grew_types.mli @@ -124,8 +124,16 @@ 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 + (** [match_list dom list g_label] returns [true] iff [g_label] + is a global label matching at least one of the p_label of [list] *) val match_list: Domain.t -> t list -> t -> bool val to_string: Domain.t -> ?locals:Label_domain.decl array -> t -> string -- GitLab