Commit 30a2f529 authored by Bruno Guillaume's avatar Bruno Guillaume

add new lexicon in matching type

parent 0cb5ece5
......@@ -432,14 +432,14 @@ module P_fs = struct
exception Fail
let match_ ?param p_fs g_fs =
let match_ ?(lexicons=[]) p_fs g_fs =
let p_fs_wo_pos =
try List.remove_assoc "position" p_fs
with Not_found -> p_fs in
let rec loop acc = function
| [], _ -> acc
(* a feature_name present only in instance -> Skip it *)
(* a feature_name present only in graph -> Skip it *)
| ((fn_pat, fv_pat)::t_pat, (fn, _)::t) when fn_pat > fn -> loop acc ((fn_pat, fv_pat)::t_pat, t)
(* Two next cases: p_fs requires for the absence of a feature -> OK *)
......@@ -451,26 +451,25 @@ module P_fs = struct
| ((fn_pat, _)::_, (fn, _)::_) when fn_pat < fn -> raise Fail
(* Next cases: fn_pat = fn *)
| ((_, {P_feature.cst=cst; P_feature.in_param=in_param})::t_pat, (_, atom)::t) ->
(* check for the constraint part and fail if needed *)
let () = match cst with
| P_feature.Absent -> raise Fail
| P_feature.Equal fv when not (List_.sort_mem atom fv) -> raise Fail
| P_feature.Different fv when List_.sort_mem atom fv -> raise Fail
| _ -> () in
(* if constraint part don't fail, look for lexical parameters *)
match (acc, in_param) with
| (_,[]) -> loop acc (t_pat,t)
| (None,_) -> Log.bug "[P_fs.match_] Parametrized constraint in a non-parametrized rule"; exit 2
| (Some param, [index]) ->
(match Lex_par.select index (string_of_value atom) param with
| [] -> raise Fail
| new_param -> loop (Some new_param) (t_pat,t)
)
| _ -> Error.bug "[P_fs.match_] several different parameters contraints for the same feature is not implemented" in
loop param (p_fs_wo_pos,g_fs)
| ((_, {P_feature.cst=P_feature.Absent})::_, (_, atom)::t) -> raise Fail
| ((_, {P_feature.cst=P_feature.Equal fv})::_, (_, atom)::t) when not (List_.sort_mem atom fv) -> raise Fail
| ((_, {P_feature.cst=P_feature.Different fv})::_, (_, atom)::t) when List_.sort_mem atom fv -> raise Fail
| ((_, {P_feature.cst=P_feature.Equal_lex (lex_name,field)})::t_pat, (_, atom)::t) ->
begin
try
let lexicon = List.assoc lex_name acc in
match Lexicon.select field (string_of_value atom) lexicon with
| None -> raise Fail
| Some new_lexicon ->
let new_acc = (lex_name, new_lexicon) :: (List.remove_assoc lex_name acc) in
loop new_acc (t_pat, t)
with
| Not_found -> failwith "TODO"
end
| _ -> acc
in loop lexicons (p_fs_wo_pos,g_fs)
exception Fail_unif
let unif fs1 fs2 =
......
......@@ -92,7 +92,9 @@ module P_fs: sig
If [param] is [None], it returns [None] if matching succeeds and else raise [Fail].
If [param] is [Some p], it returns [Some p'] if matching succeeds and else raise [Fail].
*)
val match_: ?param:Lex_par.t -> t -> G_fs.t -> Lex_par.t option
val match_:
?lexicons:(string * Grew_types.Lexicon.t) list ->
t -> G_fs.t -> (string * Grew_types.Lexicon.t) list
(** [check_position ?parma position pfs] checks wheter [pfs] is compatible with a node at [position].
It returns [true] iff [pfs] has no requirement about position ok if the requirement is satisfied. *)
......
......@@ -173,13 +173,14 @@ module P_node = struct
| Some l -> Some {t with next = l}
| None -> None
let match_ ?param p_node g_node =
let match_ ?lexicons p_node g_node =
(* (match param with None -> printf "<None>" | Some p -> printf "<Some>"; Lex_par.dump p); *)
match G_node.get_position g_node with
| G_node.Unordered _ -> None
| G_node.Unordered _ -> raise P_fs.Fail (* TOOO: check this return !! *)
| G_node.Ordered p ->
if P_fs.check_position ?param (Some p) p_node.fs
then P_fs.match_ ?param p_node.fs (G_node.get_fs g_node)
if P_fs.check_position (Some p) p_node.fs
then P_fs.match_ ?lexicons p_node.fs (G_node.get_fs g_node)
else raise P_fs.Fail
let compare_pos t1 t2 = Pervasives.compare t1.loc t2.loc
......
......@@ -106,7 +106,9 @@ module P_node: sig
val add_edge: P_edge.t -> Pid.t -> t -> t option
val match_: ?param: Lex_par.t -> t -> G_node.t -> Lex_par.t option
val match_:
?lexicons:(string * Grew_types.Lexicon.t) list ->
t -> G_node.t -> (string * Grew_types.Lexicon.t) list
val compare_pos: t -> t -> int
end
......
......@@ -601,7 +601,7 @@ module Rule = struct
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
m_param: Lex_par.t option;
(* l_param: (string * Lexicon.t) list; *)
l_param: (string * Lexicon.t) list;
}
......@@ -624,7 +624,7 @@ module Rule = struct
(P_node.get_name pnode, G_node.get_float gnode) :: acc
) n_match []
let empty_matching param = { n_match = Pid_map.empty; e_match = []; m_param = param;}
let empty_matching lexicons param = { n_match = Pid_map.empty; e_match = []; m_param = param; l_param = lexicons;}
let e_comp (e1,_) (e2,_) = compare e1 e2
......@@ -687,7 +687,7 @@ module Rule = struct
- the ?domain of the pattern P is the disjoint union of ?domain([sub]) and [unmatched_nodes]
*)
(* ---------------------------------------------------------------------- *)
let init param basic =
let init lexicons param basic =
let roots = P_graph.roots basic.graph in
let node_list = Pid_map.fold (fun pid _ acc -> pid::acc) basic.graph [] in
......@@ -700,7 +700,7 @@ module Rule = struct
| false, true -> 1
| _ -> 0) node_list in
{ sub = empty_matching param;
{ sub = empty_matching lexicons param;
unmatched_nodes = sorted_node_list;
unmatched_edges = [];
already_matched_gids = [];
......@@ -746,8 +746,8 @@ module Rule = struct
try
let gid = Pid_map.find pid matching.n_match in
let gnode = G_graph.find gid graph in
let new_param = P_fs.match_ ?param:matching.m_param fs (G_node.get_fs gnode) in
{matching with m_param = new_param }
let new_param = P_fs.match_ ~lexicons:(matching.l_param) fs (G_node.get_fs gnode) in
{matching with l_param = new_param }
with P_fs.Fail -> raise Fail
end
| Features_eq (pid1, feat_name1, pid2, feat_name2) ->
......@@ -825,7 +825,28 @@ module Rule = struct
if G_node.get_position gnode1 < G_node.get_position gnode2
then matching
else raise Fail
| Feature_eq_lex (_, _, _) |Feature_diff_lex (_, _, _) -> failwith ("TODOLEX")
| Feature_eq_lex (pid, feature_name, (lexicon,field)) ->
begin
Printf.printf "### Feature_eq_lex\n%!";
match get_string_feat pid feature_name with
| None -> raise Fail
| Some v ->
let old_lex = List.assoc lexicon matching.l_param in
match Lexicon.select field v old_lex with
| None -> raise Fail
| Some new_lex -> {matching with l_param = (lexicon, new_lex) :: (List.remove_assoc lexicon matching.l_param) }
end
| Feature_diff_lex (pid, feature_name, (lexicon,field)) ->
begin
match get_string_feat pid feature_name with
| None -> raise Fail
| Some v ->
let old_lex = List.assoc lexicon matching.l_param in
match Lexicon.unselect field v old_lex with
| None -> raise Fail
| Some new_lex -> {matching with l_param = (lexicon, new_lex) :: (List.remove_assoc lexicon matching.l_param) }
end
(* ---------------------------------------------------------------------- *)
......@@ -904,7 +925,7 @@ module Rule = struct
let g_node = try G_graph.find gid graph with Not_found -> Error.bug "[extend_matching_from] cannot find gid in graph" in
try
let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
let new_lex_set = P_node.match_ ~lexicons:partial.sub.l_param p_node g_node in
(* add all out-edges from pid in pattern *)
let new_unmatched_edges =
Massoc_pid.fold
......@@ -916,7 +937,7 @@ module Rule = struct
unmatched_nodes = (try List_.rm pid partial.unmatched_nodes with Not_found -> Error.bug "[extend_matching_from] cannot find pid in unmatched_nodes");
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; m_param = new_param};
sub = {partial.sub with n_match = Pid_map.add pid gid partial.sub.n_match; l_param = new_lex_set};
} in
extend_matching ?domain (positive,neg) graph new_partial
with P_fs.Fail -> []
......@@ -1024,7 +1045,7 @@ module Rule = struct
(function
| Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
| Command.String s -> Concat_item.String s
| Command.Lexical_field _ -> failwith "TODOLEX"
| Command.Lexical_field _ -> failwith "TODOLEX1"
| Command.Param index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
......@@ -1193,7 +1214,7 @@ module Rule = struct
| _ -> false
(* ---------------------------------------------------------------------- *)
let match_in_graph ?domain ?param (pos, negs) graph =
let match_in_graph ?domain ?(lexicons=[]) ?param (pos, negs) graph =
let casted_graph = G_graph.cast ?domain graph in
let pos_graph = pos.graph in
......@@ -1203,7 +1224,7 @@ module Rule = struct
?domain
(pos_graph,P_graph.empty)
casted_graph
(init param pos) in
(init lexicons param pos) in
let filtered_matching_list =
List.filter
......@@ -1232,7 +1253,7 @@ module Rule = struct
else
List.fold_left
(fun acc rule ->
let matching_list = match_in_graph ?domain ~param:(fst rule.param) rule.pattern instance.Instance.graph in
let matching_list = match_in_graph ?domain ~lexicons:rule.lexicons ~param:(fst rule.param) rule.pattern instance.Instance.graph in
List.fold_left
(fun acc1 matching ->
Instance_set.add (apply_rule ?domain instance matching rule) acc1
......@@ -1265,7 +1286,7 @@ module Rule = struct
?domain
(pos.graph,P_graph.empty)
instance.Instance.graph
(init (Some (fst rule.param)) pos) in
(init rule.lexicons (Some (fst rule.param)) pos) in
try
let (first_matching_where_all_witout_are_fulfilled,_) =
List.find
......@@ -1340,7 +1361,7 @@ module Rule = struct
else Error.run "max depth %d reached, last rules applied: …, %s"
!max_depth_non_det (List_.rev_to_string (fun x->x) ", " (List_.cut 5 instance.Instance.rules))
else
let matching_list = match_in_graph ?domain ?param:(Some (fst rule.param)) rule.pattern instance.Instance.graph in
let matching_list = match_in_graph ?domain ~lexicons:rule.lexicons ?param:(Some (fst rule.param)) rule.pattern instance.Instance.graph in
List.fold_left
(fun acc matching ->
Instance_set.add (apply_rule ?domain instance matching rule) acc
......@@ -1363,7 +1384,7 @@ module Rule = struct
?domain
(pos.graph,P_graph.empty)
instance.Instance.graph
(init (Some (fst rule.param)) pos) in
(init rule.lexicons (Some (fst rule.param)) pos) in
try
let (first_matching_where_all_witout_are_fulfilled,_) =
List.find
......@@ -1480,7 +1501,15 @@ module Rule = struct
(function
| Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
| Command.String s -> Concat_item.String s
| Command.Lexical_field _ -> failwith "TODOLEX"
| Command.Lexical_field (lex_name, field) ->
(try
let lexicon = List.assoc lex_name matching.l_param in
let v = Lexicon.read field lexicon in
Concat_item.String v
with
| Not_found -> Error.run ~loc "UPDATE_FEAT: the lexicon '%s' does not exist" lex_name
| Lexicon.Not_functional_lexicon -> Error.run ~loc "UPDATE_FEAT: the lexicon is not functional" lex_name
)
| Command.Param index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
......@@ -1539,7 +1568,7 @@ module Rule = struct
?domain
(pos.graph,P_graph.empty)
graph
(init (Some (fst rule.param)) pos) in
(init rule.lexicons (Some (fst rule.param)) pos) in
try
let (first_matching_where_all_witout_are_fulfilled,_) =
List.find
......@@ -1582,7 +1611,7 @@ module Rule = struct
?domain
(pos.graph,P_graph.empty)
graph
(init (Some (fst rule.param)) pos) in
(init rule.lexicons (Some (fst rule.param)) pos) in
try
let (first_matching_where_all_witout_are_fulfilled,_) =
List.find
......@@ -1723,7 +1752,7 @@ module Rule = struct
(function
| Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
| Command.String s -> Concat_item.String s
| Command.Lexical_field _ -> failwith "TODOLEX"
| Command.Lexical_field _ -> failwith "TODOLEX3"
| Command.Param index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
......@@ -1856,7 +1885,7 @@ module Rule = struct
!max_depth_non_det (List_.rev_to_string (fun x->x) ", " (List_.cut 5 instance.Instance.rules))
else
*)
let matching_list = match_in_graph ?domain ?param:(Some (fst rule.param)) rule.pattern graph_with_history.Graph_with_history.graph in
let matching_list = match_in_graph ?domain ~lexicons:rule.lexicons ?param:(Some (fst rule.param)) rule.pattern graph_with_history.Graph_with_history.graph in
List.fold_left
(fun acc matching ->
Graph_with_history_set.add (gwh_apply_rule ?domain graph_with_history matching rule) acc
......
......@@ -110,7 +110,7 @@ module Rule : sig
val node_matching: pattern -> G_graph.t -> matching -> (string * float) list
(** [match_in_graph rule graph] returns the list of matching of the pattern of the rule into the graph *)
val match_in_graph: ?domain:Domain.t -> ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
val match_in_graph: ?domain:Domain.t -> ?lexicons: (string * Lexicon.t) list -> ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
(** [match_deco rule matching] builds the decoration of the [graph] illustrating the given [matching] of the [rule] *)
(* NB: it can be computed independly from the graph itself! *)
......
......@@ -171,6 +171,7 @@ module Lexicon = struct
| (x::xs) :: xss -> (x :: List.map List.hd xss) :: transpose (xs :: List.map List.tl xss)
let build items =
if items = [] then Error.bug "[Lexicon.build] a lexicon must not be empty";
let tr = transpose items in
let sorted_tr = List.sort (fun l1 l2 -> Pervasives.compare (List.hd l1) (List.hd l2)) tr in
match transpose sorted_tr with
......@@ -204,7 +205,21 @@ module Lexicon = struct
match List_.index head lex.header with
| None -> Error.build "[Lexicon.select] cannot find %s in lexicon" head
| Some index ->
{ lex with lines = Line_set.filter (fun line -> List.nth line index = value) lex.lines}
let new_set = Line_set.filter (fun line -> List.nth line index = value) lex.lines in
if Line_set.is_empty new_set
then None
else ( Printf.printf "###>>> Lexicon select %d --> %d\n%!" (Line_set.cardinal lex.lines) (Line_set.cardinal new_set);
Some { lex with lines = new_set }
)
let unselect head value lex =
match List_.index head lex.header with
| None -> Error.build "[Lexicon.unselect] cannot find %s in lexicon" head
| Some index ->
let new_set = Line_set.filter (fun line -> List.nth line index <> value) lex.lines in
if Line_set.is_empty new_set
then None
else Some { lex with lines = new_set }
let projection head lex =
match List_.index head lex.header with
......@@ -215,14 +230,14 @@ module Lexicon = struct
exception Not_functional_lexicon
let read head lex =
match String_set.elements (projection head lex) with
| [] -> None
| [one] -> Some one
| [] -> Error.bug "[Lexicon.read] a lexicon must not be empty"
| [one] -> one
| _ -> raise Not_functional_lexicon
let read_multi head lex =
match String_set.elements (projection head lex) with
| [] -> None
| l -> Some (String.concat "/" l)
| [] -> Error.bug "[Lexicon.read] a lexicon must not be empty"
| l -> String.concat "/" l
end (* module Lexicon *)
(* ================================================================================ *)
......
......@@ -126,23 +126,20 @@ module Lexicon : sig
It supposed that the two lexicons define the same columns *)
val union: t -> t -> t
(** [select head value] returns the sublexicon with only items where the [head] column is equals to [value] *)
val select: string -> string -> t -> t
(** [select head value] returns the sublexicon with only items where the [head] column is equal to [value] if any, else returns None *)
val select: string -> string -> t -> t option
(** [unselect head value] returns the sublexicon with only items where the [head] column is different to [value] if any, else returns None *)
val unselect: string -> string -> t -> t option
exception Not_functional_lexicon
(** [read head lexicon] returns
* None if [lexicon] is empty;
* Some value if all items have a [head] column equals to [value]
* raise [Not_functional_lexicon] if several values are defined
*)
val read: string -> t -> string option
(** [read_multi head lexicon] returns
* None if [lexicon] is empty;
* Some "v_1/…/v_k" where v_i are the values of the [head] column
*)
val read_multi: string -> t -> string option
(** [read head lexicon] return [value] if all items have in the [head] column equals to [value]
* raise [Not_functional_lexicon] if several values are defined *)
val read: string -> t -> string
(** [read_multi head lexicon] returns "v_1/…/v_k" where v_i are the values of the [head] column *)
val read_multi: string -> t -> string
end (* module Lexicon *)
(* ================================================================================ *)
......
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