Commit dbc68ad1 authored by Bruno Guillaume's avatar Bruno Guillaume

add tree/forest/cycle constraints

parent 13493b75
......@@ -1286,12 +1286,16 @@ The algorithm is modified:
Tree detection is easier (is_tree <=> back_edges=0 and nontree_edges=0
*)
(* --------------------------------------------------------------- *)
let dfs_debug = false
let get_roots graph =
let non_roots =
Gid_map.fold
(fun gid node acc ->
Massoc_gid.fold_on_list (
fun acc2 next_gid _ -> Gid_set.add next_gid acc2
fun acc2 next_gid _ ->
if dfs_debug then printf " %s ---> %s\n%!" (Gid.to_string gid) (Gid.to_string next_gid);
Gid_set.add next_gid acc2
) acc (G_node.get_next node)
) graph.map Gid_set.empty in
let roots =
......@@ -1313,6 +1317,12 @@ Tree detection is easier (is_tree <=> back_edges=0 and nontree_edges=0
nontree_edges: (Gid.t * Gid.t) list;
}
type dfs_output = {
forest: bool;
tree: bool;
cyclic: bool;
}
let depth_first_search graph =
let info = ref {intervals=Gid_map.empty; back_edges=[]; nontree_edges=[];} in
let clock = ref 0 in
......@@ -1334,31 +1344,48 @@ Tree detection is easier (is_tree <=> back_edges=0 and nontree_edges=0
| _ -> assert false in
let roots = get_roots graph in
Printf.printf "|roots| = %d\n" (Gid_set.cardinal roots);
let nb_roots = Gid_set.cardinal roots in
if dfs_debug then Printf.printf "|roots| = %d\n" nb_roots;
Gid_set.iter (fun gid ->
Printf.printf " -----> explore %s\n" (Gid.to_string gid);
if dfs_debug then Printf.printf " -----> explore %s\n" (Gid.to_string gid);
explore gid
) roots;
Printf.printf "======== Intervals =======\n";
Gid_map.iter (fun gid node ->
match Gid_map.find_opt gid !info.intervals with
| None -> Printf.printf "None! %s" (Gid.to_string gid)
| Some (Pre _) -> Printf.printf "Pre! %s" (Gid.to_string gid)
| Some (Pre_post (i,j)) ->
if dfs_debug then
begin
Printf.printf "======== Intervals =======\n";
Gid_map.iter (fun gid node ->
match Gid_map.find_opt gid !info.intervals with
| None -> Printf.printf "None! %s" (Gid.to_string gid)
| Some (Pre _) -> Printf.printf "Pre! %s" (Gid.to_string gid)
| Some (Pre_post (i,j)) ->
Printf.printf "%s --> [%d,%d] --> %s\n" (Gid.to_string gid) i j
(G_fs.to_string (G_node.get_fs node))
) graph.map;
) graph.map;
Printf.printf "======== Back_edges =======\n";
List.iter (fun (gid1, gid2) ->
Printf.printf "%s --> %s\n" (Gid.to_string gid1) (Gid.to_string gid2)
) !info.back_edges;
Printf.printf "======== Back_edges =======\n";
List.iter (fun (gid1, gid2) ->
Printf.printf "%s --> %s\n" (Gid.to_string gid1) (Gid.to_string gid2)
) !info.back_edges;
Printf.printf "======== nontree_edges =======\n";
List.iter (fun (gid1, gid2) ->
Printf.printf "%s --> %s\n" (Gid.to_string gid1) (Gid.to_string gid2)
) !info.nontree_edges
Printf.printf "======== nontree_edges =======\n";
List.iter (fun (gid1, gid2) ->
Printf.printf "%s --> %s\n" (Gid.to_string gid1) (Gid.to_string gid2)
) !info.nontree_edges
end;
if Gid_map.cardinal !info.intervals < Gid_map.cardinal graph.map
then
begin
if dfs_debug then printf "Not covered\n%!";
{ forest = false; tree = false; cyclic = true}
end
else
{
forest = !info.nontree_edges = [] && !info.back_edges = [];
tree = !info.nontree_edges = [] && !info.back_edges = [] && nb_roots = 1;
cyclic = !info.back_edges <> [];
}
end (* module G_graph *)
......
......@@ -213,7 +213,13 @@ module G_graph: sig
val is_projective: t -> (Gid.t * Gid.t) option
val depth_first_search: t -> unit
type dfs_output = {
forest: bool;
tree: bool;
cyclic: bool;
}
val depth_first_search: t -> dfs_output
end (* module G_graph *)
(* ================================================================================ *)
......
......@@ -947,21 +947,47 @@ module Rule = struct
let match_in_graph ?domain ?lexicons { global; pos; negs } graph =
let casted_graph = G_graph.cast ?domain graph in
let rec match_global = function
let match_global = function
| [] -> true
| "is_projective" :: tail ->
begin
match G_graph.is_projective graph with
| Some _ -> false
| None -> match_global tail
end
| "is_not_projective" :: tail ->
begin
match G_graph.is_projective graph with
| Some _ -> match_global tail
| None -> false
end
| x :: tail -> Error.build "Unknown global requirement \"%s\"" x in
| ["is_projective"] -> G_graph.is_projective graph = None
| ["is_not_projective"] -> G_graph.is_projective graph <> None
| l ->
let dfs = G_graph.depth_first_search graph in
let rec loop = function
| [] -> true
| "is_projective" :: tail ->
begin
match G_graph.is_projective graph with
| Some _ -> false
| None -> loop tail
end
| "is_not_projective" :: tail ->
begin
match G_graph.is_projective graph with
| Some _ -> loop tail
| None -> false
end
| "is_tree" :: tail when dfs.tree -> loop tail
| "is_tree" :: _ -> false
| "is_not_tree" :: tail when not dfs.tree -> loop tail
| "is_not_tree" :: _ -> false
| "is_forest" :: tail when dfs.forest -> loop tail
| "is_forest" :: _ -> false
| "is_not_forest" :: tail when not dfs.forest -> loop tail
| "is_not_forest" :: _ -> false
| "is_cyclic" :: tail when dfs.cyclic -> loop tail
| "is_cyclic" :: _ -> false
| "is_not_cyclic" :: tail when not dfs.cyclic -> loop tail
| "is_not_cyclic" :: _ -> false
| x :: tail -> Error.build "Unknown global requirement \"%s\"" x in
loop l in
if not (match_global global)
then []
......
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