Commit e58b2558 authored by Bruno Guillaume's avatar Bruno Guillaume

improve feature unification (unif f=v1|v2 with f<>v1)

improve error reporting on feature unification
add handling of parameters in whitout parts
parent 0455c29d
......@@ -93,7 +93,7 @@ module Ast = struct
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
| Equal_param of string (* $ident *)
| Absent
type u_feature = {
......@@ -181,7 +181,7 @@ module Ast = struct
neg_patterns: pattern list;
commands: command list;
param: (string list * string list) option;
lp: string list option;
lex_par: string list option;
rule_doc:string list;
rule_loc: Loc.t;
}
......
......@@ -45,7 +45,7 @@ module Ast : sig
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
| Equal_param of string (* $ident *)
| Absent
type u_feature = {
......@@ -119,7 +119,7 @@ module Ast : sig
neg_patterns: pattern list;
commands: command list;
param: (string list * string list) option; (* (files, vars) *)
lp: string list option; (* lexical parameters in the file *)
lex_par: string list option; (* lexical parameters in the file *)
rule_doc:string list;
rule_loc: Loc.t;
}
......
......@@ -61,6 +61,12 @@ module String_ = struct
let of_float float = Str.global_replace (Str.regexp ",") "." (sprintf "%g" float)
let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)
let rm_peripheral_white s =
s
|> (Str.global_replace (Str.regexp "\\( \\|\t\\)*$") "")
|> (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "")
end (* module String_ *)
(* ================================================================================ *)
......
......@@ -26,6 +26,10 @@ module String_: sig
(* [rm_first_char s] returns the string [s] without the first charater if s is not empty.
If s in empty, the empty string is returned *)
val rm_first_char: string -> string
(* [rm_peripheral_white s] returns the string [s] without any white space ot tab
at the beginning or at the end of the string. *)
val rm_peripheral_white: string -> string
end
......@@ -91,7 +95,8 @@ module List_: sig
val set: int -> 'a -> 'a list -> 'a list
(** [pos elt list] return [Some index] if [index] is the smallest position in the [list] equals to [elt]. None is returned if [elt] is not in the [list] *)
(** [pos elt list] return [Some index] if [index] is the smallest position in the [list] equals to [elt].
None is returned if [elt] is not in the [list] *)
val pos: 'a -> 'a list -> int option
val opt_map: ('a -> 'b option) -> 'a list -> 'b list
......
This diff is collapsed.
......@@ -74,7 +74,7 @@ module P_fs: sig
exception Fail
(** [match_ ?param t gfs] tries to match the pattern fs [pfs] with the graph fs [gfs]
(** [match_ ?param p_fs g_fs] tries to match the pattern fs [p_fs] with the graph fs [g_fs].
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].
*)
......@@ -84,7 +84,8 @@ module P_fs: sig
It returns [true] iff [pfs] has no requirement about position ok if the requirement is satisfied. *)
val check_position: ?param:Lex_par.t -> float -> t -> bool
val filter: t -> G_fs.t -> bool
(** [unif fs1 fs2] returns the unification of the two feature structures.
It raises (Error.Build msg) exception in case of Failure.
*)
val unif: t -> t -> t
end (* module P_fs *)
......@@ -60,7 +60,10 @@ module P_graph = struct
let rec insert (ast_node, loc) = function
| [] -> [P_node.build ?pat_vars (ast_node, loc)]
| (node_id,fs)::tail when ast_node.Ast.node_id = node_id ->
(node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
begin
try (node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
with Error.Build (msg,_) -> raise (Error.Build (msg,Some loc))
end
| head :: tail -> head :: (insert (ast_node, loc) tail) in
let (named_nodes : (Id.name * P_node.t) list) =
......@@ -104,9 +107,9 @@ module P_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let build_extension ?(locals=[||]) pos_table full_node_list full_edge_list =
let build_extension ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let built_nodes = List.map P_node.build full_node_list in
let built_nodes = List.map (P_node.build ?pat_vars) full_node_list in
let (old_nodes, new_nodes) =
List.partition
......
......@@ -60,6 +60,7 @@ module P_graph: sig
(t * Id.table)
val build_extension:
?pat_vars: string list ->
?locals: Label.decl array ->
Id.table ->
Ast.node list ->
......
......@@ -80,7 +80,7 @@ module Html_doc = struct
sprintf "!%s" u_feature.Ast.name
| Ast.Disequality values ->
sprintf "%s<>%s" u_feature.Ast.name (List_.to_string (fun x->x) "|" values)
| Ast.Param index ->
| Ast.Equal_param index ->
sprintf "%s=%s" u_feature.Ast.name index
let buff_html_node buff (u_node,_) =
......@@ -275,7 +275,7 @@ module Html_doc = struct
wnl "<h6>Lexical parameters</h6>";
(* output local lexical parameters (if any) *)
(match rule_.Ast.lp with
(match rule_.Ast.lex_par with
| None -> ()
| Some lines ->
wnl "<b>Local parameters</b><br/>";
......
......@@ -70,7 +70,10 @@ module P_node: sig
val get_fs: t -> P_fs.t
val get_next: t -> P_edge.t Massoc_pid.t
(** [unif_fs fs t] replaces the feature structure of the node by node.fs unif fs *)
(** [unif_fs fs t] replaces the feature structure of the node
by the unification of [node.fs] ] and [fs].
It raises (Error.Build msg) exception in case of Failure.
*)
val unif_fs: P_fs.t -> t -> t
val build: ?pat_vars: string list -> Ast.node -> (Id.name * t)
......
......@@ -169,9 +169,9 @@ module Rule = struct
and (node_name2, feat_name2) = qfn2 in
Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
let build_neg_pattern ?(locals=[||]) pos_table pattern_ast =
let build_neg_pattern ~pat_vars ?(locals=[||]) pos_table pattern_ast =
let (extension, neg_table) =
P_graph.build_extension ~locals pos_table pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
P_graph.build_extension ~pat_vars ~locals pos_table pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
let filters = Pid_map.fold (fun id node acc -> Filter (id, P_node.get_fs node) :: acc) extension.P_graph.old_map [] in
{
graph = extension.P_graph.ext_map;
......@@ -302,24 +302,25 @@ module Rule = struct
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
let param = List.fold_left
let local_param = match rule_ast.Ast.lex_par with
| None -> None
| Some lines -> Some (Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines) in
let full_param = List.fold_left
(fun acc file ->
Lex_par.append
(Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
acc
)
(match rule_ast.Ast.lp with
| None -> Lex_par.empty
| Some lines -> Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines
)
files in
(Some param, pat_vars, cmd_vars) in
match acc with
| None -> Some (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
| Some lp -> Some (Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file) lp)
) local_param files in
(full_param, pat_vars, cmd_vars) in
let (pos, pos_table) = build_pos_pattern ~pat_vars ~locals rule_ast.Ast.pos_pattern in
{
name = rule_ast.Ast.rule_id;
pos = pos;
neg = List.map (fun pattern_ast -> build_neg_pattern ~locals pos_table pattern_ast) rule_ast.Ast.neg_patterns;
neg = List.map (fun pattern_ast -> build_neg_pattern ~pat_vars ~locals pos_table pattern_ast) rule_ast.Ast.neg_patterns;
commands = build_commands ~param:(pat_vars,cmd_vars) ~locals suffixes pos pos_table rule_ast.Ast.commands;
loc = rule_ast.Ast.rule_loc;
param = param;
......@@ -425,7 +426,7 @@ module Rule = struct
}
(* ---------------------------------------------------------------------- *)
let fullfill graph matching cst =
let apply_cst graph matching cst =
let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
let get_string_feat pid = function
| "position" -> Some (sprintf "%g" (G_node.get_position (get_node pid)))
......@@ -437,45 +438,61 @@ module Rule = struct
match cst with
| Cst_out (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
G_graph.edge_out graph gid edge
if G_graph.edge_out graph gid edge
then matching
else raise Fail
| Cst_in (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
G_graph.node_exists
if G_graph.node_exists
(fun node ->
List.exists (fun e -> P_edge.compatible edge e) (Massoc_gid.assoc gid (G_node.get_next node))
) graph
then matching
else raise Fail
| Filter (pid, fs) ->
let gid = Pid_map.find pid matching.n_match in
let gnode = G_graph.find gid graph in
P_fs.filter fs (G_node.get_fs gnode)
begin
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 }
with P_fs.Fail -> raise Fail
end
| Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
begin
match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
| Some fv1, Some fv2 when fv1 = fv2 -> true
| _ -> false
| Some fv1, Some fv2 when fv1 = fv2 -> matching
| _ -> raise Fail
end
| Feature_diseq (pid1, feat_name1, pid2, feat_name2) ->
begin
match (get_string_feat pid1 feat_name1, get_string_feat pid2 feat_name2) with
| Some fv1, Some fv2 when fv1 <> fv2 -> true
| _ -> false
| Some fv1, Some fv2 when fv1 <> fv2 -> matching
| _ -> raise Fail
end
| Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
match (ineq, get_float_feat pid1 feat_name1, get_float_feat pid2 feat_name2) with
| (Ast.Lt, Some fv1, Some fv2) when fv1 < fv2 -> true
| (Ast.Gt, Some fv1, Some fv2) when fv1 > fv2 -> true
| (Ast.Le, Some fv1, Some fv2) when fv1 <= fv2 -> true
| (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> true
| _ -> false
| (Ast.Lt, Some fv1, Some fv2) when fv1 < fv2 -> matching
| (Ast.Gt, Some fv1, Some fv2) when fv1 > fv2 -> matching
| (Ast.Le, Some fv1, Some fv2) when fv1 <= fv2 -> matching
| (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> matching
| _ -> raise Fail
(* ---------------------------------------------------------------------- *)
(* returns all extension of the partial input matching *)
let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
match (partial.unmatched_edges, partial.unmatched_nodes) with
| [], [] ->
if List.for_all (fun const -> fullfill graph partial.sub const) partial.check
then [partial.sub, partial.already_matched_gids]
else []
begin
try
let new_matching =
List.fold_left
(fun acc const ->
apply_cst graph acc const
) partial.sub partial.check in
[new_matching, partial.already_matched_gids]
with Fail -> []
end
| (src_pid, p_edge, tar_pid)::tail_ue, _ ->
begin
try (* is the tar already found in the matching ? *)
......@@ -541,9 +558,7 @@ module Rule = struct
let g_node = try G_graph.find gid graph with Not_found -> failwith "INS" in
try
let new_param = P_node.match_ ?param: partial.sub.m_param p_node g_node in
(* add all out-edges from pid in pattern *)
let new_unmatched_edges =
Massoc_pid.fold
......@@ -797,10 +812,10 @@ module Rule = struct
(* ---------------------------------------------------------------------- *)
let fulfill (pos_graph,neg_graph) graph new_partial_matching =
let fulfill (pos_graph,neg_graph) graph new_partial_matching =
match extend_matching (pos_graph, neg_graph) graph new_partial_matching with
| [] -> true (* the without pattern in not found -> OK *)
| x -> false
| _ -> false
(* ================================================================================ *)
......
......@@ -391,9 +391,13 @@ module Lex_par = struct
type t = item list
let empty=[]
let size = List.length
let append = List.append
let signature = function
| [] -> Error.bug "[Lex_par.signature] empty data"
| (pp,cp)::_ -> (List.length pp,List.length cp)
let dump t =
printf "[Lex_par.dump] --> size = %d\n" (List.length t);
List.iter (fun (pp,cp) ->
......@@ -402,12 +406,8 @@ module Lex_par = struct
(String.concat "#" cp)
) t
let rm_peripheral_white s =
Str.global_replace (Str.regexp "\\( \\|\t\\)*$") ""
(Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "" s)
let parse_line ?loc nb_p nb_c line =
let line = rm_peripheral_white line in
let line = String_.rm_peripheral_white line in
if line = "" || line.[0] = '%'
then None
else
......@@ -415,18 +415,21 @@ module Lex_par = struct
| [args] when nb_c = 0 ->
(match Str.split (Str.regexp "#") args with
| l when List.length l = nb_p -> Some (l,[])
| _ -> Error.bug ?loc
| _ -> Error.build ?loc
"Illegal lexical parameter line: \"%s\" doesn't contain %d args"
line nb_p)
| [args; values] ->
(match (Str.split (Str.regexp "#") args, Str.split (Str.regexp "#") values) with
| (lp,lc) when List.length lp = nb_p && List.length lc = nb_c -> Some (lp,lc)
| _ -> Error.bug ?loc
| _ -> Error.build ?loc
"Illegal lexical parameter line: \"%s\" doesn't contain %d args and %d values"
line nb_p nb_c)
| _ -> Error.bug ?loc "Illegal param line: '%s'" line
| _ -> Error.build ?loc "Illegal param line: '%s'" line
let from_lines ?loc nb_p nb_c lines = List_.opt_map (parse_line ?loc nb_p nb_c) lines
let from_lines ?loc nb_p nb_c lines =
match List_.opt_map (parse_line ?loc nb_p nb_c) lines with
| [] -> Error.build ?loc "Empty lexical parameter list"
| l -> l
let load ?loc dir nb_p nb_c file =
try
......@@ -435,22 +438,19 @@ module Lex_par = struct
then Filename.concat dir file
else file in
let lines = File.read full_file in
List_.opt_mapi (fun i line -> parse_line ~loc:(Loc.file_line full_file i) nb_p nb_c line) lines
match List_.opt_mapi (fun i line -> parse_line ~loc:(Loc.file_line full_file i) nb_p nb_c line) lines with
| [] -> Error.build ?loc "Empty lexical parameter file '%s'" file
| l -> l
with Sys_error _ -> Error.build ?loc "External lexical file '%s' not found" file
let sub x y = List.mem x (Str.split (Str.regexp "|") y)
let filter index atom t =
let select index atom t =
match
List_.opt_map
(fun (p_par, c_par) ->
let par = List.nth p_par index in
if atom=par
if atom = par
then Some (p_par, c_par)
else
if sub atom par (* atom is one of the values of the disjunction par *)
then Some (List_.set index atom p_par, c_par)
else None
else None
) t
with
| [] -> None
......
......@@ -149,22 +149,26 @@ end (* module Conll *)
module Lex_par: sig
type t
val empty:t
val append: t -> t -> t
val dump: t -> unit
val size: t -> int
(** [signature t] returns (number of pattern parameters, number of lexical parameters) *)
val signature: t -> (int * int)
(** [from_lines filename nb_pattern_var nb_command_var strings] *)
val from_lines: ?loc: Loc.t -> int -> int -> string list -> t
(** [load ?loc local_dir_name nb_pattern_var nb_command_var file] *)
val load: ?loc: Loc.t -> string -> int -> int -> string -> t
(** [filter index atom t] returns the subset of [t] which contains only entries
(** [select index atom t] returns the subset of [t] which contains only entries
which refers to [atom] at the [index]^th pattern_var.
[None] is returnes if no such entry s founded.
[None] is returned if no such entry s founded.
*)
val filter: int -> string -> t -> t option
val select: int -> string -> t -> t option
(** [get_param_value index t] returns the [index]^th param_var. *)
val get_param_value: int -> t -> string
......
This diff is collapsed.
......@@ -86,7 +86,7 @@ and string_lex target = parse
and lp_lex target = parse
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; bprintf buff "\n"; lp_lex target lexbuf }
| _ as c { bprintf buff "%c" c; lp_lex target lexbuf }
| "#END" [' ' '\t']* '\n' { incr Parser_global.current_line; LP (Str.split (Str.regexp "\n") (Buffer.contents buff)) }
| "#END" [' ' '\t']* '\n' { incr Parser_global.current_line; LEX_PAR (Str.split (Str.regexp "\n") (Buffer.contents buff)) }
and global = parse
| [' ' '\t'] { global lexbuf }
......
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