Commit 11c31ce4 authored by bguillaum's avatar bguillaum

parametrized rules

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@6757 7838e531-6607-4d57-9587-6c381814729c
parent d7f0eec1
......@@ -10,14 +10,16 @@ module Ast = struct
type domain = feature_spec list
type feature_kind = Equality | Disequality
type feature_kind =
| Equality of string list
| Disequality of string list
| Param of string
type u_feature = {
kind: feature_kind;
name: string;
values: string list;
}
kind: feature_kind;
}
type feature = u_feature * Loc.t
(* qualified feature name "A.lemma" *)
......@@ -76,8 +78,8 @@ module Ast = struct
| Del_node of Id.name
| Del_feat of qfn
| Update_feat of qfn * concat_item list
| Param_feat of qfn * string
type command = u_command * Loc.t
......@@ -86,6 +88,7 @@ module Ast = struct
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string*string list) option;
rule_doc:string;
rule_loc: Loc.t;
}
......@@ -159,7 +162,9 @@ module AST_HTML = struct
| Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s \n" n1 label n2
| Ast.Del_node n -> bprintf buff "del_node %s" n
| Ast.Update_feat (qfn,item_list) -> bprintf buff "%s = %s" (string_of_qfn qfn) (List_.to_string string_of_concat_item " + " item_list)
| Ast.Del_feat qfn -> bprintf buff "del_feat %s" (string_of_qfn qfn));
| Ast.Del_feat qfn -> bprintf buff "del_feat %s" (string_of_qfn qfn)
| Ast.Param_feat (qfn, var) -> bprintf buff "param_feat %s @ %s" (string_of_qfn qfn) var)
;
if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
let to_html_commands_pretty = function
......@@ -172,11 +177,12 @@ module AST_HTML = struct
Buffer.contents buff
let buff_html_feature buff (u_feature,_) =
bprintf buff "%s %s %s"
u_feature.Ast.name
(match u_feature.Ast.kind with Ast.Equality -> "=" | Ast.Disequality -> "<>")
(List_.to_string (fun x->x) ", " u_feature.Ast.values)
bprintf buff "%s" u_feature.Ast.name;
match u_feature.Ast.kind with
| Ast.Equality values -> bprintf buff " = %s" (List_.to_string (fun x->x) ", " values)
| Ast.Disequality values -> bprintf buff " <> %s" (List_.to_string (fun x->x) ", " values)
| Ast.Param index -> bprintf buff "@%s" index
let buff_html_node buff (u_node,_) =
bprintf buff " %s [" u_node.Ast.node_id;
List.iter (buff_html_feature buff) u_node.Ast.fs;
......
......@@ -7,12 +7,14 @@ module Ast : sig
type domain = feature_spec list
type feature_kind = Equality | Disequality
type feature_kind =
| Equality of string list
| Disequality of string list
| Param of string
type u_feature = {
kind: feature_kind;
name: string;
values: string list;
kind: feature_kind;
}
type feature = u_feature * Loc.t
......@@ -70,8 +72,8 @@ module Ast : sig
| Del_node of Id.name
| Del_feat of qfn
| Update_feat of qfn * concat_item list
| Param_feat of qfn * string
type command = u_command * Loc.t
type rule = {
......@@ -79,6 +81,7 @@ module Ast : sig
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string*string list) option;
rule_doc:string;
rule_loc: Loc.t;
}
......
......@@ -26,6 +26,7 @@ module Command = struct
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| PARAM_FEAT of (cnode * string * int)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
......@@ -48,7 +49,7 @@ module Command = struct
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
let build ?domain (kni, kei) table locals ast_command =
let build ?cmd_vars ?domain (kni, kei) table locals ast_command =
let get_pid node_name =
match Id.build_opt node_name table with
| Some id -> Pid id
......@@ -124,5 +125,15 @@ module Command = struct
ast_items in
((UPDATE_FEAT (get_pid tar_node, tar_feat_name, items), loc), (kni, kei))
| (Ast.Param_feat ((node,feat_name), var), loc) ->
match cmd_vars with
| None -> Error.build "Unknown command variable '%s'" var
| Some l ->
match List_.pos var l with
| Some index -> ((PARAM_FEAT (get_pid node, feat_name, index), loc), (kni, kei))
| None -> Error.build "Unknown command variable '%s'" var
end
......@@ -21,6 +21,7 @@ module Command : sig
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| PARAM_FEAT of (cnode * string * int)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
......@@ -43,6 +44,7 @@ module Command : sig
| H_MERGE_NODE of (gid * gid)
val build:
?cmd_vars: string list ->
?domain:Ast.domain ->
(string list * string list) ->
Id.table ->
......
......@@ -9,8 +9,9 @@ module Feature = struct
type t =
| Equal of string * string list
| Different of string * string list
| Param of string * int
let get_name = function | Equal (n,_) -> n | Different (n,_) -> n
let get_name = function | Equal (n,_) -> n | Different (n,_) | Param (n,_) -> n
let get_atom = function | Equal (n,[one]) -> Some one | _ -> None
......@@ -30,25 +31,30 @@ module Feature = struct
)
| Some (_::t) -> check ~domain:t loc name values
let build ?domain = function
| ({Ast.kind=Ast.Equality;name=name;values=unsorted_values},loc) ->
let build ?pat_vars ?domain = function
| ({Ast.kind=Ast.Equality unsorted_values ;name=name},loc) ->
let values = List.sort Pervasives.compare unsorted_values in
check ?domain loc name values;
Equal (name, values)
| ({Ast.kind=Ast.Disequality;name=name;values=unsorted_values},loc) ->
| ({Ast.kind=Ast.Disequality unsorted_values;name=name},loc) ->
let values = List.sort Pervasives.compare unsorted_values in
check ?domain loc name values;
Different (name, values)
| ({Ast.kind=Ast.Param var; name=name},loc) ->
match pat_vars with
| None -> Error.build "Unknown pattern variable '%s'" var
| Some l ->
match List_.pos var l with
| Some index -> Param (name, index)
| None -> Error.build "Unknown pattern variable '%s'" var
end
module Feature_structure = struct
(* list are supposed to be striclty ordered wrt compare*)
type t = Feature.t list
let build ?domain ast_fs =
let unsorted = List.map (Feature.build ?domain) ast_fs in
let build ?pat_vars ?domain ast_fs =
let unsorted = List.map (Feature.build ?pat_vars ?domain) ast_fs in
List.sort Feature.compare unsorted
let of_conll line =
......@@ -70,6 +76,7 @@ module Feature_structure = struct
| Feature.Equal (n,l) :: t when n<name -> get name t
| Feature.Equal _ :: _ -> None
| Feature.Different _ :: _ -> Log.critical "[Feature_structure.get] this fs contains 'Different' constructor"
| Feature.Param _ :: _ -> Log.critical "[Feature_structure.get] this fs contains 'Param' constructor"
let get_atom name t =
match get name t with
......@@ -89,7 +96,8 @@ module Feature_structure = struct
| [] -> "EMPTY"
| h::t -> List.fold_right (fun atom acc -> atom^"|"^acc) t h
)
| Feature.Param (feat_name, index) ->
sprintf "@%d" index
let to_string t = List_.to_string string_of_feature "\\n" t
......@@ -152,7 +160,6 @@ module Feature_structure = struct
| Feature.Equal (fn,ats)::t -> Feature.Equal (fn,ats):: (del_feat feature_name t)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
(* WARNING: different from prev implem: does not fail when pattern contains a feature_name or in instance *)
let compatible pattern fs =
let rec loop = function
| [], _ -> true
......@@ -180,13 +187,62 @@ module Feature_structure = struct
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv_pat, fv with
| [],_ | _, [] -> loop (t_pat,t)
| [],_ | _, [] -> loop (t_pat,t) (* FIXME should be "false" *)
| l_pat,l -> (List_.sort_disjoint l_pat l) && loop (t_pat,t)
)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
in loop (pattern,fs)
let compatible_param param pattern fs =
let rec loop acc_param = function
| [], _ -> acc_param
(* Three next cases: each feature_name present in pattern must be in instance: [] means unif failure *)
| _, [] -> []
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> []
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> []
(* Two next cases: a feature in graph, not in pattern *)
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Equal (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Different (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Param (fn_pat, i))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Param (fn_pat, i))::t_pat, t)
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn *) ->
(match fv_pat, fv with
| [],_ -> (* pattern_value is ? *) loop acc_param (t_pat,t)
| l_pat,l when not (List_.sort_disjoint l_pat l) -> loop acc_param (t_pat,t)
| _ -> (* l_pat and l disjoint -> no sol *) []
)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv_pat, fv with
| [],_ -> []
| l_pat,l when List_.sort_disjoint l_pat l -> loop acc_param (t_pat,t)
| _ -> (* l_pat and l disjoint -> no disjoint *) []
)
| ((Feature.Param (fn_pat, i))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv with
| [atom] ->
let reduce_param = List.filter (fun (x,_) -> List.nth x i = atom) acc_param in
loop reduce_param (t_pat,t)
| _ -> Log.critical "[compatible_param] Graph feature value not atomic"
)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
in loop param (pattern,fs)
exception Fail_unif
exception Bug_unif of string
let unif fs1 fs2 =
......
......@@ -8,7 +8,7 @@ end
module Feature_structure: sig
type t
val build: ?domain:Ast.domain -> Ast.feature list -> t
val build: ?pat_vars: string list -> ?domain:Ast.domain -> Ast.feature list -> t
val of_conll: Conll.line -> t
......@@ -32,6 +32,7 @@ module Feature_structure: sig
val compatible: t -> t -> bool
val compatible_param: (string list * string list) list -> t -> t -> (string list * string list) list
(** [unif t1 t2] returns [Some t] if [t] is the unification of two graph feature structures
[None] is returned if the two feature structures cannot be unified
......
......@@ -41,7 +41,7 @@ module P_graph = struct
let fs = Feature_structure.build ?domain ast_node.Ast.fs in
(pid, fs)
let build ?domain ?(locals=[||]) full_node_list full_edge_list =
let build ?pat_vars ?domain ?(locals=[||]) full_node_list full_edge_list =
let (named_nodes, constraints) =
let rec loop already_bound = function
......@@ -50,7 +50,7 @@ module P_graph = struct
let (tail_nodes, tail_const) = loop (ast_node.Ast.node_id :: already_bound) tail in
if List.mem ast_node.Ast.node_id already_bound
then (tail_nodes, (ast_node, loc)::tail_const)
else (P_node.build ?domain (ast_node, loc) :: tail_nodes, tail_const) in
else (P_node.build ?pat_vars ?domain (ast_node, loc) :: tail_nodes, tail_const) in
loop [] full_node_list in
(* let named_nodes = List.map (Node.build ?domain) full_node_list in *)
......@@ -242,6 +242,7 @@ module G_graph = struct
let of_conll lines =
let nodes =
List.fold_left
(fun acc line -> Gid_map.add line.Conll.num (G_node.of_conll line) acc)
......@@ -253,7 +254,9 @@ module G_graph = struct
if line.Conll.gov=0
then acc
else
let gov_node = Gid_map.find line.Conll.gov acc in
let gov_node =
try Gid_map.find line.Conll.gov acc
with Not_found -> Log.fcritical "Ill-formed CONLL file: line number %d refers to the on existing gov %d" line.Conll.num line.Conll.gov in
match G_node.add_edge (G_edge.make line.Conll.dep_lab) line.Conll.num gov_node with
| None -> acc
| Some new_node -> Gid_map.add line.Conll.gov new_node acc
......@@ -412,8 +415,12 @@ module G_graph = struct
| None -> None
(* FIXME: check consistency wrt the domain *)
let set_feat graph node_id feat_name new_value =
let node = Gid_map.find node_id graph.map in
let new_fs = Feature_structure.set_feat feat_name [new_value] (G_node.get_fs node) in
{graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map}
let update_feat graph tar_id tar_feat_name item_list =
let tar = Gid_map.find tar_id graph.map in
let strings_to_concat =
List.map
(function
......@@ -429,8 +436,13 @@ module G_graph = struct
| String s -> s
) item_list in
let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
let new_fs = Feature_structure.set_feat tar_feat_name [new_feature_value] (G_node.get_fs tar) in
({graph with map = Gid_map.add tar_id (G_node.set_fs tar new_fs) graph.map}, new_feature_value)
(set_feat graph tar_id tar_feat_name new_feature_value, new_feature_value)
(* let tar = Gid_map.find tar_id graph.map in *)
(* let new_fs = Feature_structure.set_feat tar_feat_name [new_feature_value] (G_node.get_fs tar) in *)
(* ({graph with map = Gid_map.add tar_id (G_node.set_fs tar new_fs) graph.map}, new_feature_value) *)
(** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
If the feature is not present, [graph] is returned. *)
......
......@@ -25,6 +25,7 @@ module P_graph: sig
}
val build:
?pat_vars: string list ->
?domain: Ast.domain ->
?locals: Label.decl array ->
Ast.node list ->
......@@ -93,6 +94,8 @@ module G_graph: sig
It returns both the new graph and the new feature value produced as the second element *)
val update_feat : t -> int -> string -> concat_item list -> (t * string)
val set_feat: t -> int -> string -> string -> t
val del_feat : t -> int -> string -> t
(** [edge_out t id edge] returns true iff there is an out-edge from the node [id] with a label compatible with [edge] *)
......
......@@ -83,9 +83,9 @@ module P_node = struct
let empty = { fs = Feature_structure.empty; next = Massoc.empty }
let build ?domain (ast_node, loc) =
let build ?pat_vars ?domain (ast_node, loc) =
(ast_node.Ast.node_id,
{ fs = Feature_structure.build ?domain ast_node.Ast.fs;
{ fs = Feature_structure.build ?pat_vars ?domain ast_node.Ast.fs;
next = Massoc.empty;
} )
......@@ -97,6 +97,7 @@ module P_node = struct
(* Says that "pattern" t1 is a t2*)
let is_a p_node g_node = Feature_structure.compatible p_node.fs (G_node.get_fs g_node)
let is_a_param param p_node g_node = Feature_structure.compatible_param param p_node.fs (G_node.get_fs g_node)
end
(* ================================================================================ *)
......
......@@ -46,11 +46,12 @@ module P_node: sig
val get_fs: t -> Feature_structure.t
val get_next: t -> P_edge.t Massoc.t
val build: ?domain:Ast.domain -> Ast.node -> (Id.name * t)
val build: ?pat_vars: string list -> ?domain:Ast.domain -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> int -> t -> t option
val is_a: t -> G_node.t -> bool
val is_a_param: (string list * string list) list -> t -> G_node.t -> (string list * string list) list
end
(* ================================================================================ *)
......@@ -85,8 +85,8 @@ module Rule = struct
constraints: const list;
}
let build_pos_pattern ?domain ?(locals=[||]) pattern_ast =
let (graph,table,filter_nodes) = P_graph.build ?domain ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
let build_pos_pattern ?pat_vars ?domain ?(locals=[||]) pattern_ast =
let (graph,table,filter_nodes) = P_graph.build ?pat_vars ?domain ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
(
{
graph = graph;
......@@ -115,7 +115,6 @@ module Rule = struct
let filters = Pid_map.fold (fun id node acc -> Filter (id, P_node.get_fs node) :: acc) extension.P_graph.old_map [] in
(* (\* DEBUG *\) Printf.printf "-----> |filters| = %d\n%!" (List.length filters); *)
{
graph = extension.P_graph.ext_map;
constraints = filters @ List.map (build_neg_constraint ~locals pos_table neg_table) pattern_ast.Ast.pat_const ;
......@@ -135,51 +134,86 @@ module Rule = struct
neg: pattern list;
commands: Command.t list;
loc: Loc.t;
param: (string list * string list) list option;
}
let get_name t = t.name
let get_loc t = t.loc
let build_commands ?domain ?(locals=[||]) pos pos_table ast_commands =
let build_commands ?cmd_vars ?domain ?(locals=[||]) pos pos_table ast_commands =
let known_node_ids = Array.to_list pos_table in
let known_edge_ids = get_edge_ids pos in
let rec loop (kni,kei) = function
| [] -> []
| ast_command :: tail ->
let (command, (new_kni, new_kei)) =
Command.build ?domain (kni,kei) pos_table locals ast_command in
Command.build ?cmd_vars ?domain (kni,kei) pos_table locals ast_command in
command :: (loop (new_kni,new_kei) tail) in
loop (known_node_ids, known_edge_ids) ast_commands
let parse_vars loc vars =
let rec parse_cmd_vars = function
| [] -> []
| x::t when x.[0] = '@' -> x :: parse_cmd_vars t
| x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
let rec parse_pat_vars = function
| [] -> ([],[])
| x::t when x.[0] = '@' -> ([],parse_cmd_vars (x::t))
| x::t when x.[0] = '$' -> let (pv,cv) = parse_pat_vars t in (x::pv, cv)
| x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
parse_pat_vars vars
let build ?domain ?(locals=[||]) rule_ast =
let (pos,pos_table) = build_pos_pattern ?domain ~locals rule_ast.Ast.pos_pattern in
let (param, pat_vars, cmd_vars) =
match rule_ast.Ast.param with
| None -> (None,[],[])
| Some (file,vars) ->
let (pat_vars, cmd_vars) = parse_vars rule_ast.Ast.rule_loc vars in
let nb_pv = List.length pat_vars in
let nb_cv = List.length cmd_vars in
try
let lines = File.read file in
let param = Some
(List.map
(fun line ->
match Str.split (Str.regexp "##") line with
| [args] when cmd_vars = [] ->
(match Str.split (Str.regexp "#") args with
| l when List.length l = nb_pv -> (l,[])
| _ -> Error.bug "Illegal param line in file '%s' line '%s' hasn't %d args" file line nb_pv)
| [args; values] ->
(match (Str.split (Str.regexp "#") args, Str.split (Str.regexp "#") values) with
| (lp,lc) when List.length lp = nb_pv && List.length lc = nb_cv -> (lp,lc)
| _ -> Error.bug "Illegal param line in file '%s' line '%s' hasn't %d args and %d values" file line nb_pv nb_cv)
| _ -> Error.bug "Illegal param line in file '%s' line '%s'" file line
) lines
) in
(param, pat_vars, cmd_vars)
with Sys_error _ -> Error.build ~loc:rule_ast.Ast.rule_loc "File '%s' not found" file in
let (pos,pos_table) = build_pos_pattern ~pat_vars ?domain ~locals rule_ast.Ast.pos_pattern in
{
name = rule_ast.Ast.rule_id ;
name = rule_ast.Ast.rule_id;
pos = pos;
neg = List.map (fun p -> build_neg_pattern ?domain ~locals pos_table p) rule_ast.Ast.neg_patterns;
commands = build_commands ?domain ~locals pos pos_table rule_ast.Ast.commands;
commands = build_commands ~cmd_vars ?domain ~locals pos pos_table rule_ast.Ast.commands;
loc = rule_ast.Ast.rule_loc;
param = param;
}
type matching = {
n_match: gid Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
n_match: gid Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(gid*Label.t*gid)) list; (* edge matching: edge ident |--> (src,label,tar) *)
a_match: (gid*Label.t*gid) list; (* anonymous edge mached *)
m_param: (string list * string list) list option;
}
let empty_matching = { n_match = Pid_map.empty; e_match = []; a_match = [];}
let singleton_matching i j = { empty_matching with n_match = Pid_map.add i j Pid_map.empty }
let empty_matching param = { n_match = Pid_map.empty; e_match = []; a_match = []; m_param = param;}
let e_comp (e1,_) (e2,_) = compare e1 e2
let union match1 match2 = {
n_match = Pid_map.union_if match1.n_match match2.n_match;
e_match = List_.sort_disjoint_union ~compare:e_comp match1.e_match match2.e_match;
a_match = match1.a_match @ match2.a_match;
}
let e_match_add ?pos edge_id matching =
match List_.usort_insert ~compare:e_comp edge_id matching.e_match with
......@@ -235,7 +269,7 @@ module Rule = struct
- the domain of the pattern P is the disjoint union of domain([sub]) and [unmatched_nodes]
*)
let init pattern =
let init param pattern =
let roots = P_graph.roots pattern.graph in
let node_list = Pid_map.fold (fun pid _ acc -> pid::acc) pattern.graph [] in
......@@ -248,7 +282,7 @@ module Rule = struct
| false, true -> 1
| _ -> 0) node_list in
{ sub = empty_matching;
{ sub = empty_matching param;
unmatched_nodes = sorted_node_list;
unmatched_edges = [];
already_matched_gids = [];
......@@ -282,7 +316,6 @@ module Rule = struct
let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
match (partial.unmatched_edges, partial.unmatched_nodes) with
| [], [] ->
(* (\* DEBUG *\) Printf.printf "==<1>==\n%!"; *)
if List.for_all (fun const -> fullfill graph partial.sub const) partial.check
then [partial.sub, partial.already_matched_gids]
else []
......@@ -342,24 +375,31 @@ module Rule = struct
then try P_graph.find pid positive with Not_found -> failwith "POS"
else try P_graph.find pid neg with Not_found -> failwith "NEG" in
let g_node = try G_graph.find gid graph with Not_found -> failwith "INS" in
if not (P_node.is_a p_node g_node)
then [] (* the nodes don't match *)
else
try
let new_param =
match partial.sub.m_param with
| None when P_node.is_a p_node g_node -> None
| None -> raise Fail
| Some param ->
match P_node.is_a_param param p_node g_node with
| [] -> raise Fail
| new_param -> Some new_param in
(* add all out-edges from pid in pattern *)
let new_unmatched_edges =
Massoc.fold_left
(fun acc pid_next p_edge -> (pid, p_edge, pid_next) :: acc
) partial.unmatched_edges (P_node.get_next p_node) in
let new_partial = { partial with
unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> failwith "List_.rm");
unmatched_edges = new_unmatched_edges;
already_matched_gids = gid :: partial.already_matched_gids;
sub = {partial.sub with n_match = Pid_map.add pid gid partial.sub.n_match};
} in
let new_partial =