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
......
This diff is collapsed.
......@@ -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