Commit 765c19a0 authored by bguillaum's avatar bguillaum

add features equality test in patterns

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@6685 7838e531-6607-4d57-9587-6c381814729c
parent 1c4b5064
......@@ -19,7 +19,8 @@ type u_feature = {
}
type feature = u_feature * Loc.t
(* qualified feature name "A.lemma" *)
type qfn = string * string
type u_node = {
node_id: Id.name;
......@@ -43,6 +44,7 @@ type u_const =
| No_out of Id.name
| End of Id.name * string list (* (target, labels) *)
| No_in of Id.name
| Feature_eq of qfn * qfn
type const = u_const * Loc.t
......@@ -59,7 +61,7 @@ type graph = {
}
type concat_item =
| Feat_item of string
| Qfn_item of (string * string)
| String_item of string
type u_command =
......@@ -71,9 +73,9 @@ type u_command =
| New_neighbour of (Id.name * Id.name * string)
| Del_node of Id.name
| Del_feat of string
| Del_feat of qfn
| Update_feat of string * concat_item list
| Update_feat of qfn * concat_item list
type command = u_command * Loc.t
......@@ -134,9 +136,11 @@ module AST_HTML = struct
let feat_values_tab_to_html = List_.to_string (fun x->x) " | "
let string_of_concat_item = function
| Feat_item f -> f
| Qfn_item (n,f) -> sprintf "%s.%s" n f
| String_item s -> sprintf "\"%s\"" s
let string_of_qfn (node, feat_name) = sprintf "%s.%s" node feat_name
let buff_html_command ?(li_html=false) buff (u_command,_) =
bprintf buff " ";
if li_html then bprintf buff "<li>";
......@@ -148,8 +152,8 @@ module AST_HTML = struct
| Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" n1 n2
| New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s \n" n1 label n2
| Del_node n -> bprintf buff "del_node %s" n
| Update_feat (f,item_list) -> bprintf buff "%s = %s" f (List_.to_string string_of_concat_item " + " item_list)
| Del_feat feat -> bprintf buff "del_feat %s" feat);
| Update_feat (qfn,item_list) -> bprintf buff "%s = %s" (string_of_qfn qfn) (List_.to_string string_of_concat_item " + " item_list)
| Del_feat qfn -> bprintf buff "del_feat %s" (string_of_qfn qfn));
if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
let to_html_commands_pretty = function
......@@ -187,7 +191,8 @@ module AST_HTML = struct
| Start (id,labels) -> bprintf buff "%s -[%s]-> *" id (List_.to_string (fun x->x) "|" labels)
| No_out id -> bprintf buff "%s -> *" id
| End (id,labels) -> bprintf buff "* -[%s]-> %s" (List_.to_string (fun x->x) "|" labels) id
| No_in id -> bprintf buff "* -> %s" id);
| No_in id -> bprintf buff "* -> %s" id
| Feature_eq (qfn_l, qfn_r) -> bprintf buff "%s = %s" (string_of_qfn qfn_l) (string_of_qfn qfn_r));
bprintf buff "\n"
......
......@@ -16,7 +16,8 @@ type u_feature = {
type feature = u_feature * Loc.t
(* qualified feature name "A.lemma" *)
type qfn = string * string
type u_node = {
node_id: Id.name;
......@@ -42,6 +43,7 @@ type u_const =
| No_out of Id.name
| End of Id.name * string list (* (target, labels) *)
| No_in of Id.name
| Feature_eq of qfn * qfn
type const = u_const * Loc.t
......@@ -52,7 +54,7 @@ type pattern = {
}
type concat_item =
| Feat_item of string
| Qfn_item of (string * string)
| String_item of string
type u_command =
......@@ -64,9 +66,9 @@ type u_command =
| New_neighbour of (Id.name * Id.name * string)
| Del_node of Id.name
| Del_feat of string
| Del_feat of qfn
| Update_feat of string * concat_item list
| Update_feat of qfn * concat_item list
type command = u_command * Loc.t
type rule = {
......
......@@ -51,11 +51,6 @@ module Command = struct
| Some id -> Pid id
| None -> New node_name in
let parse_feat loc string_feat =
match Str.split (Str.regexp "\\.") string_feat with
| [node; feat_name] -> (get_pid node, feat_name)
| _ -> Log.fcritical "[GRS] \"%s\" is not a feature %s" string_feat (Loc.to_string loc) in
match ast_command with
| (Ast.Del_edge_expl (i, j, lab), loc) ->
let edge = Edge.make ~locals [lab] in
......@@ -88,17 +83,14 @@ module Command = struct
| (Ast.Del_node n, loc) ->
(DEL_NODE (get_pid n), loc)
| (Ast.Del_feat (feat), loc) ->
let (node_pid, feat_name) = parse_feat loc feat in
(DEL_FEAT (node_pid, feat_name), loc)
| (Ast.Del_feat (node,feat_name), loc) ->
(DEL_FEAT (get_pid node, feat_name), loc)
| (Ast.Update_feat (feat, ast_items), loc) ->
let (node_pid, feat_name) = parse_feat loc feat in
| (Ast.Update_feat ((tar_node, tar_feat_name), ast_items), loc) ->
let items = List.map
(function
| Ast.Feat_item feat -> Feat (parse_feat loc feat)
| Ast.Qfn_item (node,feat_name) -> Feat (get_pid node, feat_name)
| Ast.String_item s -> String s)
ast_items in
(UPDATE_FEAT (node_pid, feat_name, items), loc)
(UPDATE_FEAT (get_pid tar_node, tar_feat_name, items), loc)
end
......@@ -22,11 +22,11 @@ gr_grs_parser.cmo: gr_grs_parser.mly ../utils.cmo ../ast.cmx parser_global.cmo
lexer.cmx: gr_grs_parser.cmx lexer.mll ../ast.cmx
ocamllex lexer.mll
ocamlopt -c $(OPT_FLAGS) lexer.ml
ocamlopt -c $(OPT_FLAGS) -I .. ast.cmx lexer.ml
lexer.cmo: gr_grs_parser.cmo lexer.mll ../ast.cmo
ocamllex lexer.mll
ocamlc -c $(BYTE_FLAGS) lexer.ml
ocamlc -c $(BYTE_FLAGS) -I .. ast.cmo lexer.ml
grew_parser.cmx: gr_grs_parser.cmx lexer.cmx grew_parser.ml ../ast.cmx
ocamlopt -c $(OPT_FLAGS) -I .. ast.cmx grew_parser.ml
......
......@@ -3,7 +3,7 @@
open Ast
open Utils
(* Some intermediate sum types used in sub-functions when xsvbuilding the ast *)
(* Some intermediate sum types used in sub-functions when building the ast *)
type pat_item =
| Pat_node of node
| Pat_edge of edge
......@@ -60,11 +60,11 @@ let localize t = (t,get_loc ())
%token ADD_NODE /* add_node */
%token DEL_FEAT /* del_feat */
%token <string> IDENT /* indentifier */
%token <string> FEAT /* ident.ident */
%token <string> STRING
%token <int> NUMBER
%token <string> COMMENT
%token <string> IDENT /* indentifier */
%token <Ast.qfn> QFN /* ident.ident */
%token <string> STRING
%token <int> INT
%token <string> COMMENT
%token EOF /* end of file */
......@@ -98,7 +98,7 @@ gr_item:
{ Graph_edge (localize {edge_id = None; src=n1; edge_labels=labels; tar=n2; negative=false; }) }
index:
| NUMBER { $1 }
| INT { $1 }
......@@ -316,11 +316,11 @@ rule_doc:
pat_item:
| n = node { Pat_node n }
| e = full_edge { Pat_edge e }
| c = full_const { Pat_const c }
| n = pat_node { Pat_node n }
| e = pat_edge { Pat_edge e }
| c = pat_const { Pat_const c }
node:
pat_node:
| id = IDENT feats = delimited(LBRACKET,separated_list(COMA,node_features),RBRACKET)
{ localize ({node_id = id; position=None; fs= feats}) }
......@@ -338,9 +338,9 @@ node_features:
feature_value:
| v = IDENT { v }
| v = STRING { v }
| v = NUMBER { string_of_int v }
| v = INT { string_of_int v }
full_edge:
pat_edge:
(* "e: A -> B" *)
| id = edge_id n1 = IDENT GOTO_NODE n2 = IDENT
| id = edge_id n1 = IDENT LTR_EDGE_LEFT_NEG STAR LTR_EDGE_RIGHT n2 = IDENT
......@@ -371,7 +371,7 @@ edge_id:
| id = IDENT DDOT { id }
full_const:
pat_const:
(* "A -[X|Y]-> *" *)
| n1 = IDENT labels = delimited(LTR_EDGE_LEFT,separated_nonempty_list(PIPE,IDENT),LTR_EDGE_RIGHT) STAR
{ localize (Start (n1,labels)) }
......@@ -388,6 +388,9 @@ full_const:
| STAR GOTO_NODE n2 = IDENT
{ localize (No_in n2) }
| qfn1 = QFN EQUAL qfn2 = QFN
{ localize (Feature_eq (qfn1, qfn2)) }
/*=============================================================================================*/
/* */
/* COMMANDS DEFINITION */
......@@ -432,13 +435,13 @@ command:
{ localize (Del_node n) }
| ADD_NODE n1 = IDENT DDOT label = delimited(RTL_EDGE_LEFT,IDENT,RTL_EDGE_RIGHT) n2 = IDENT
{ localize (New_neighbour (n1,n2,label)) }
| DEL_FEAT feat = FEAT
{ localize (Del_feat feat) }
| feat = FEAT EQUAL items = separated_nonempty_list (PLUS, concat_item)
{ localize (Update_feat (feat, items)) }
| DEL_FEAT qfn = QFN
{ localize (Del_feat qfn) }
| qfn = QFN EQUAL items = separated_nonempty_list (PLUS, concat_item)
{ localize (Update_feat (qfn, items)) }
concat_item:
| feat = FEAT { Feat_item feat }
| qfn = QFN { Qfn_item qfn }
| s = IDENT { String_item s }
| s = STRING { String_item s }
......
{
open Log
open Ast
open Gr_grs_parser
exception Error of string
let tmp_string = ref ""
let escaped = ref false
let parse_qfn string_feat =
match Str.split (Str.regexp "\\.") string_feat with
| [node; feat_name] -> (node, feat_name)
| _ -> Log.fcritical "[BUG] \"%s\" is not a feature" string_feat
}
let digit = ['0'-'9']
......@@ -37,7 +44,7 @@ and string_lex target = parse
| "\\" { escaped := true; tmp_string := !tmp_string^"\\"; string_lex target lexbuf }
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; tmp_string := !tmp_string^"\n"; string_lex target lexbuf }
| '\"' { if !escaped then (tmp_string := !tmp_string^"\""; escaped := false; string_lex target lexbuf) else ( STRING(!tmp_string) ) }
| _ as c { tmp_string := !tmp_string^(Printf.sprintf "%c" c); string_lex target lexbuf }
| _ as c { escaped := false; tmp_string := !tmp_string^(Printf.sprintf "%c" c); string_lex target lexbuf }
and global = parse
......@@ -71,10 +78,10 @@ and global = parse
| "rule" { RULE }
| "sequences" { SEQUENCES }
| "graph" { GRAPH }
| "graph" { GRAPH }
| digit+ as number { NUMBER (int_of_string number) }
| ident ['.'] ident as feat { FEAT feat }
| digit+ as number { INT (int_of_string number) }
| ident ['.'] ident as qfn { QFN (parse_qfn qfn) }
| ident as id { IDENT id }
......
......@@ -63,15 +63,18 @@ module Rule = struct
exception Bound_reached
type const =
| No_out of int * Edge.t
| No_in of int * Edge.t
| Filter of int * Feature_structure.t (* used when a without impose a fs on a node defined by the match pattern *)
| No_out of pid * Edge.t
| No_in of pid * Edge.t
| Feature_eq of pid * string * pid * string
| Filter of pid * Feature_structure.t (* used when a without impose a fs on a node defined by the match pattern *)
let build_constraint ?locals table = function
| (Ast.Start (node_name, labels), loc) -> No_out (Id.build ~loc node_name table, Edge.make ?locals labels)
| (Ast.No_out node_name, loc) -> No_out (Id.build ~loc node_name table, Edge.all)
| (Ast.End (node_name, labels),loc) -> No_in (Id.build ~loc node_name table, Edge.make ?locals labels)
| (Ast.No_in node_name, loc) -> No_in (Id.build ~loc node_name table, Edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (Id.build ~loc node_name1 table, feat_name1, Id.build ~loc node_name2 table, feat_name2)
type pattern =
{ graph: Graph.t;
......@@ -97,6 +100,8 @@ module Rule = struct
| (Ast.No_out node_name, loc) -> No_out (id_build loc node_name, Edge.all)
| (Ast.End (node_name, labels),loc) -> No_in (id_build loc node_name, Edge.make ?locals labels)
| (Ast.No_in node_name, loc) -> No_in (id_build loc node_name, Edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (id_build loc node_name1, feat_name1, id_build loc node_name2, feat_name2)
let build_neg_pattern ?domain ?(locals=[||]) pos_table pattern_ast =
let (extension, neg_table) =
......@@ -234,6 +239,10 @@ module Rule = struct
(fun _ node ->
List.exists (fun e -> Edge.compatible edge e) (Massoc.assoc gid node.Node.next)
) graph.Graph.map
| Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
let gnode1 = IntMap.find (IntMap.find pid1 matching.n_match) graph.Graph.map in
let gnode2 = IntMap.find (IntMap.find pid2 matching.n_match) graph.Graph.map in
Feature_structure.get feat_name1 gnode1.Node.fs = Feature_structure.get feat_name2 gnode2.Node.fs
| Filter (pid, fs) ->
let gid = IntMap.find pid matching.n_match in
let gnode = IntMap.find gid graph.Graph.map in
......
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