Commit a3444c29 authored by bguillaum's avatar bguillaum

inequality management

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7571 7838e531-6607-4d57-9587-6c381814729c
parent c66b444e
......@@ -41,14 +41,24 @@ module Ast = struct
negative: bool;
}
type edge = u_edge * Loc.t
type ineq = Lt | Gt | Le | Ge
let string_of_ineq = function
| Lt -> "<"
| Gt -> ">"
| Le -> "≤"
| Ge -> "≥"
type u_const =
| Start of Id.name * string list (* (source, labels) *)
| Cst_out of Id.name
| End of Id.name * string list (* (target, labels) *)
| Cst_in of Id.name
| Feature_eq of qfn * qfn
| Feature_diseq of qfn * qfn
| Feature_ineq of ineq * qfn * qfn
type const = u_const * Loc.t
type pattern = {
......
......@@ -16,7 +16,7 @@ module Ast : sig
type u_feature = {
name: string;
kind: feature_kind;
}
}
type feature = u_feature * Loc.t
......@@ -41,12 +41,18 @@ module Ast : sig
type edge = u_edge * Loc.t
type ineq = Lt | Gt | Le | Ge
val string_of_ineq: ineq -> string
type u_const =
| Start of Id.name * string list (* (source, labels) *)
| Cst_out of Id.name
| End of Id.name * string list (* (target, labels) *)
| Cst_in of Id.name
| Feature_eq of qfn * qfn
| Feature_diseq of qfn * qfn
| Feature_ineq of ineq * qfn * qfn
type const = u_const * Loc.t
......
......@@ -180,6 +180,12 @@ module G_fs = struct
| None -> None
| Some v -> Some (string_of_value v)
let get_int_feat feat_name t =
match List_.sort_assoc feat_name t with
| None -> None
| Some (Int i) -> Some i
| Some _ -> Error.build "[Fs.get_int_feat]"
let to_string t = List_.to_string G_feature.to_string "," t
let to_gr t = List_.to_string G_feature.to_gr ", " t
......
......@@ -25,6 +25,7 @@ module G_fs: sig
It returns [None] if there is no feature named [f] in [t] *)
val get_string_atom: string -> t -> string option
val get_int_feat: string -> t -> int option
val to_gr: t -> string
val to_dot: ?main_feat: string -> t -> string
val to_word: ?main_feat: string -> t -> string
......
......@@ -83,7 +83,9 @@ module Html_doc = struct
| Ast.Cst_out id -> bprintf buff "%s -> *" id
| Ast.End (id,labels) -> bprintf buff "* -[%s]-> %s" (List_.to_string (fun x->x) "|" labels) id
| Ast.Cst_in id -> bprintf buff "* -> %s" id
| Ast.Feature_eq (qfn_l, qfn_r) -> bprintf buff "%s = %s" (string_of_qfn qfn_l) (string_of_qfn qfn_r));
| Ast.Feature_eq (qfn_l, qfn_r) -> bprintf buff "%s = %s" (string_of_qfn qfn_l) (string_of_qfn qfn_r)
| Ast.Feature_diseq (qfn_l, qfn_r) -> bprintf buff "%s <> %s" (string_of_qfn qfn_l) (string_of_qfn qfn_r)
| Ast.Feature_ineq (ineq, qfn_l, qfn_r) -> bprintf buff "%s %s %s" (string_of_qfn qfn_l) (Ast.string_of_ineq ineq) (string_of_qfn qfn_r));
bprintf buff "\n"
let buff_html_pos_pattern buff pos_pattern =
......
......@@ -79,6 +79,9 @@ module Rule = struct
| Cst_out of pid * P_edge.t
| Cst_in of pid * P_edge.t
| Feature_eq of pid * string * pid * string
| Feature_diseq of pid * string * pid * string
| Feature_ineq of Ast.ineq * pid * string * pid * string
| Filter of pid * P_fs.t (* used when a without impose a fs on a node defined by the match pattern *)
let build_pos_constraint ?locals pos_table const =
......@@ -94,6 +97,10 @@ module Rule = struct
Cst_in (pid_of_name loc node_name, P_edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
| (Ast.Feature_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
| (Ast.Feature_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_ineq (ineq, pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
type pattern = {
graph: P_graph.t;
......@@ -128,6 +135,10 @@ module Rule = struct
Cst_in (pid_of_name loc node_name, P_edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
| (Ast.Feature_diseq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_diseq (pid_of_name loc node_name1, feat_name1, pid_of_name loc node_name2, feat_name2)
| (Ast.Feature_ineq (ineq, (node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
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 (extension, neg_table) =
......@@ -370,28 +381,44 @@ module Rule = struct
(* (\* Ocaml < 3.12 doesn't have exists function for maps! *\) *)
let fullfill graph matching = function
| Cst_out (pid,edge) ->
let fullfill graph matching cst =
let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
let get_string_feat pid feat_name = G_fs.get_string_atom feat_name (G_node.get_fs (get_node pid)) in
let get_int_feat pid feat_name = G_fs.get_int_feat feat_name (G_node.get_fs (get_node pid)) in
match cst with
| Cst_out (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
G_graph.edge_out graph gid edge
| Cst_in (pid,edge) ->
| Cst_in (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
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
| Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
let gnode1 = G_graph.find (Pid_map.find pid1 matching.n_match) graph in
let gnode2 = G_graph.find (Pid_map.find pid2 matching.n_match) graph in
(match (G_fs.get_string_atom feat_name1 (G_node.get_fs gnode1),
G_fs.get_string_atom feat_name2 (G_node.get_fs gnode2)
) with
| Some fv1, Some fv2 when fv1 = fv2 -> true
| _ -> false)
| Filter (pid, fs) ->
| 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)
| 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
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
end
| Feature_ineq (ineq, pid1, feat_name1, pid2, feat_name2) ->
match (ineq, get_int_feat pid1 feat_name1, get_int_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
(* returns all extension of the partial input matching *)
let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
......
......@@ -32,6 +32,12 @@ let localize t = (t,get_loc ())
%token PLUS /* + */
%token EQUAL /* = */
%token DISEQUAL /* <> */
%token LT /* < */
%token GT /* > */
%token LE /* <= or */
%token GE /* >= or */
%token PIPE /* | */
%token GOTO_NODE /* -> */
%token LTR_EDGE_LEFT /* -[ */
......@@ -124,14 +130,14 @@ gr_item:
{ Graph_meta (id, value) }
(* B (1) [phon="pense", lemma="penser", cat=v, mood=ind ] *)
| id = IDENT position = option(delimited(LPAREN,index,RPAREN)) feats = delimited(LBRACKET,separated_list_final_opt(COMA,node_features),RBRACKET)
| id = IDENT position = option(delimited(LPAREN,num,RPAREN)) feats = delimited(LBRACKET,separated_list_final_opt(COMA,node_features),RBRACKET)
{ Graph_node (localize {Ast.node_id = id; position=position; fs=feats}) }
(* A -[x|y|z]-> B*)
| n1 = IDENT labels = delimited(LTR_EDGE_LEFT,separated_nonempty_list(PIPE,IDENT),LTR_EDGE_RIGHT) n2 = IDENT
{ Graph_edge (localize {Ast.edge_id = None; src=n1; edge_labels=labels; tar=n2; negative=false; }) }
index:
num:
| INT { $1 }
......@@ -196,7 +202,6 @@ features_group:
%inline features:
| LACC x = separated_nonempty_list_final_opt(SEMIC,feature) RACC { x }
%inline feature:
| name = feature_name DDOT values = features_values
{
......@@ -433,7 +438,6 @@ pat_edge:
edge_id:
| id = IDENT DDOT { id }
pat_const:
(* "A -[X|Y]-> *" *)
......@@ -452,9 +456,26 @@ pat_const:
| STAR GOTO_NODE n2 = IDENT
{ localize (Ast.Cst_in n2) }
(* X.cat = Y.cat *)
| qfn1 = QFN EQUAL qfn2 = QFN
{ localize (Ast.Feature_eq (qfn1, qfn2)) }
(* X.num < Y.num *)
| qfn1 = QFN LT qfn2 = QFN
{ localize (Ast.Feature_ineq (Ast.Lt, qfn1, qfn2)) }
(* X.num > Y.num *)
| qfn1 = QFN GT qfn2 = QFN
{ localize (Ast.Feature_ineq (Ast.Gt, qfn1, qfn2)) }
(* X.num <= Y.num *)
| qfn1 = QFN LE qfn2 = QFN
{ localize (Ast.Feature_ineq (Ast.Le, qfn1, qfn2)) }
(* X.num >= Y.num *)
| qfn1 = QFN GE qfn2 = QFN
{ localize (Ast.Feature_ineq (Ast.Ge, qfn1, qfn2)) }
/*=============================================================================================*/
/* */
/* COMMANDS DEFINITION */
......
......@@ -120,6 +120,12 @@ and global = parse
| '#' { SHARP }
| '=' { EQUAL }
| "<>" { DISEQUAL }
| "<" { LT }
| ">" { GT }
| "<=" | "≤" { LE }
| ">=" | "≥" { GE }
| '|' { PIPE }
| "->" { GOTO_NODE }
| "-[^" { LTR_EDGE_LEFT_NEG }
......
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