Commit 613ef276 authored by bguillaum's avatar bguillaum

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
parent 1a0f4cae
......@@ -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 *)
......@@ -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 ->
......
......@@ -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 *)
......
......@@ -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
......
......@@ -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
......
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