diff --git a/src/grew_edge.ml b/src/grew_edge.ml index fd72c415cbebb05c244011dd3359d1a416304b36..03d7d39c0790ee9126c8712bf365f90c32cb53ad 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 34bd87b430356fa00cd5fb555848b50d7edfb011..3971d4e2f2a37df034e3f7fcef6aaf35dea8ed18 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 a033d19f7220baea49aa4cb147387b79223b3a15..bd5d8b0737fc785c2cd8abc2e7c33ee05edd3306 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 43a050947ef66562a3796eac2425bb9d9ba12ed9..636dee307d229bb6374b9f27017bcbd5f6e27c92 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 f04e70f39d77d4f9a279848aac499c3ff860a6a4..0faee0e692d16ff482be6a404deba06f19bc9982 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