diff --git a/src/grew_fs.ml b/src/grew_fs.ml
index 19b390d921831b1ce31f754a2683d9380e274294..9b0f9f20a03727f7e02943ecdb4860364f921e0d 100644
--- a/src/grew_fs.ml
+++ b/src/grew_fs.ml
@@ -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 =
diff --git a/src/grew_fs.mli b/src/grew_fs.mli
index ecdb2a7ed36f755ac0ac69534687920602302f5a..f146a5798a0045b59734736be939fa7c444aff05 100644
--- a/src/grew_fs.mli
+++ b/src/grew_fs.mli
@@ -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. *)
diff --git a/src/grew_node.ml b/src/grew_node.ml
index ee7e54c57faa9ba52674490da3170bf29bc4ddd0..fff467a2dddaff2836fc473b38cee6ac5e68c35c 100644
--- a/src/grew_node.ml
+++ b/src/grew_node.ml
@@ -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
diff --git a/src/grew_node.mli b/src/grew_node.mli
index ee51aca942e390daa8c9188ac2995006af284620..59246904ba5e18a60d6d01b9b7ed9b7e1c9425d4 100644
--- a/src/grew_node.mli
+++ b/src/grew_node.mli
@@ -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
diff --git a/src/grew_rule.ml b/src/grew_rule.ml
index 4044ad0bf70176dae982249ce23df22759abea0d..0c438363de9bd7908b764ed7b17abe2ff003f2f5 100644
--- a/src/grew_rule.ml
+++ b/src/grew_rule.ml
@@ -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
diff --git a/src/grew_rule.mli b/src/grew_rule.mli
index db3c0613d0156ed617f93acd62fd749a5df1fa6b..0e9b641a98b5b13fd7742e65bc4625bf0b5d54b6 100644
--- a/src/grew_rule.mli
+++ b/src/grew_rule.mli
@@ -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! *)
diff --git a/src/grew_types.ml b/src/grew_types.ml
index 4ffbbe40ca2f72e96091c74f2f569dc167d566cb..0edcaa758b518f3f0632acce5cc369e5bcd9e2d9 100644
--- a/src/grew_types.ml
+++ b/src/grew_types.ml
@@ -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 *)
(* ================================================================================ *)
diff --git a/src/grew_types.mli b/src/grew_types.mli
index 4b5c9755a799a897634ae5afe107db0ddcc4173e..aa5c321997ec6cd7c7fcdb4ee2b97df1b23470e6 100644
--- a/src/grew_types.mli
+++ b/src/grew_types.mli
@@ -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 *)
(* ================================================================================ *)