Commit e90891d7 authored by Bruno Guillaume's avatar Bruno Guillaume

activate mechanism to create new nodes

parent 7a67b63c
......@@ -3,10 +3,10 @@
;; Mode used to write Grew with emacs (highlight)
;; see: https://wikilligramme.loria.fr/doku.php?id=grew:grew
(require 'generic-x) ;;pour Emacs OK, mais semble ne pas marcher avec XEmacs
(require 'generic-x) ;;pour Emacs OK, mais semble ne pas marcher avec XEmacs
(define-generic-mode 'grew-mode
'("%");;comments
'("features" "module" "rule" "lex_rule" "match" "without" "labels" "sequences" "commands" "graph" "confluent" "include" "filter");;keywords
'("features" "module" "rule" "lex_rule" "match" "without" "labels" "sequences" "commands" "graph" "confluent" "include" "filter" "suffixes");;keywords
'(
;; ("class\\s (\*\*)* +\\(\\sw[a-zA-Z0-9_.-]*\\)" 1 'font-lock-type-face);noms de classes
;; ("\?[a-zA-Z0-9]+" . font-lock-variable-name-face)
......
......@@ -10,7 +10,6 @@
open Printf
open Log
open Libgrew_utils
module Ast = struct
......@@ -22,6 +21,7 @@ module Ast = struct
type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
type suffix = string
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
......@@ -217,7 +217,7 @@ module Ast = struct
type modul = {
module_id:Id.name;
local_labels: (string * string list) list;
new_node_names: string list;
suffixes: string list;
rules: rule list;
confluent: bool;
module_doc:string list;
......
......@@ -9,11 +9,12 @@
(**********************************************************************************)
open Libgrew_utils
module Ast : sig
type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
type suffix = string
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
......@@ -46,7 +47,7 @@ module Ast : sig
val act_qfn_of_ci: complex_id -> act_qfn
type feature_spec =
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Int of feature_name (* position *)
......@@ -54,7 +55,7 @@ module Ast : sig
type domain = feature_spec list
val normalize_domain: domain -> domain
type feature_kind =
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
......@@ -88,7 +89,7 @@ module Ast : sig
type ineq = Lt | Gt | Le | Ge
val string_of_ineq: ineq -> string
type u_const =
type u_const =
| Start of Id.name * edge_label list (* (source, labels) *)
| Cst_out of Id.name
| End of Id.name * edge_label list (* (target, labels) *)
......@@ -109,7 +110,7 @@ module Ast : sig
| String_item of string
| Param_item of string
type u_command =
type u_command =
| Del_edge_expl of (act_id * act_id * edge_label)
| Del_edge_name of string
| Add_edge of (act_id * act_id * edge_label)
......@@ -135,36 +136,36 @@ module Ast : sig
rule_doc:string list;
rule_loc: Loc.t;
}
type modul = {
module_id:Id.name;
local_labels: (string * string list) list;
new_node_names: string list;
suffixes: string list;
rules: rule list;
confluent: bool;
module_doc:string list;
mod_loc:Loc.t;
mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
}
type sequence = {
seq_name:string;
seq_mod:string list;
seq_doc:string list;
seq_loc:Loc.t;
}
(**
a GRS: graph rewriting system
(**
a GRS: graph rewriting system
*)
type module_or_include =
type module_or_include =
| Modul of modul
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: domain;
labels_wi: (string * string list) list; (* the list of global edge labels *)
modules_wi: module_or_include list;
modules_wi: module_or_include list;
sequences_wi: sequence list;
}
......
......@@ -63,7 +63,7 @@ module Command = struct
| H_MERGE_NODE of (Gid.t * Gid.t)
| H_ACT_NODE of (Gid.t * string)
let build ?param (kai, kei) table locals ast_command =
let build ?param (kai, kei) table locals suffixes ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *)
let pid_of_act_id loc = function
......@@ -143,12 +143,15 @@ module Command = struct
(Loc.to_string loc)
end
| (Ast.Activate (_,None), loc) ->
Error.build ~loc "Cannot activate a pattern node"
| (Ast.Activate act_n, loc) ->
(* TODO: add a check on source node *)
((ACT_NODE (pid_of_act_id loc act_n), loc), (act_n :: kai, kei))
begin
match act_n with
| (_,None) -> Error.build ~loc "Cannot activate a pattern node"
| (src, Some suffix) ->
check_act_id loc (src,None) kai;
if not (List.mem suffix suffixes) then Error.build ~loc "Undefined suffix \"%s\"" suffix;
((ACT_NODE (pid_of_act_id loc act_n), loc), (act_n :: kai, kei))
end
| (Ast.Del_node act_n, loc) ->
check_act_id loc act_n kai;
......
......@@ -60,6 +60,7 @@ module Command : sig
(Ast.act_id list * string list) ->
Id.table ->
Label.decl array ->
Ast.suffix list ->
Ast.command ->
t * (Ast.act_id list * string list)
end (* module Command *)
......@@ -229,6 +229,30 @@ module G_graph = struct
map: G_node.t Gid_map.t; (* node description *)
}
(* -------------------------------------------------------------------------------- *)
let rename mapping graph =
{graph with map =
Gid_map.fold
(fun id node acc ->
let new_id = try List.assoc id mapping with Not_found -> id in
let new_node = G_node.rename mapping node in
Gid_map.add new_id new_node acc
) graph.map Gid_map.empty
}
(* -------------------------------------------------------------------------------- *)
(* [normalize g] changes all graphs keys to Old _ (used when entering a new module) *)
let normalize t =
let (_, mapping) =
Gid_map.fold
(fun key value (max_binding, mapping) ->
match key with
| Gid.Old n -> (n, mapping)
| Gid.New _ -> (max_binding, mapping)
| Gid.Act (n,suffix) -> (max_binding+1, (key, (Gid.Old (max_binding+1)))::mapping)
) t.map (0, []) in
rename mapping t
let empty = {meta=[]; map=Gid_map.empty}
let find node_id graph = Gid_map.find node_id graph.map
......@@ -416,17 +440,6 @@ module G_graph = struct
(* Update functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* -------------------------------------------------------------------------------- *)
let rename mapping graph =
{graph with map =
Gid_map.fold
(fun id node acc ->
let new_id = try List.assoc id mapping with Not_found -> id in
let new_node = G_node.rename mapping node in
Gid_map.add new_id new_node acc
) graph.map Gid_map.empty
}
(* -------------------------------------------------------------------------------- *)
let del_edge ?edge_ident loc graph id_src label id_tar =
let node_src =
......@@ -450,13 +463,13 @@ module G_graph = struct
}
(* -------------------------------------------------------------------------------- *)
let activate loc node_id new_name graph =
let activate loc node_id suffix graph =
let index = match node_id with
| Gid.Old id -> Gid.Act (id, new_name)
| Gid.Old id -> Gid.Act (id, suffix)
| _ -> Error.run ~loc "[Graph.activate] is possible only from a \"ground\" node" in
if Gid_map.mem index graph.map
then Error.run ~loc "[Graph.activate] try to activate twice the \"same\" node (with new_name '%s')" new_name;
then Error.run ~loc "[Graph.activate] try to activate twice the \"same\" node (with suffix '%s')" suffix;
let node = Gid_map.find node_id graph.map in
let new_map = Gid_map.add index (G_node.build_new node) graph.map in
......@@ -470,7 +483,7 @@ module G_graph = struct
| Some label_int -> Gid.New (id, label_int)
| None -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour with a local label"
)
| Gid.New _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
| Gid.New _ | Gid.Act _ -> Error.run ~loc "[Graph.add_neighbour] try to add neighbour node to a neighbour node" in
if Gid_map.mem index graph.map
then Error.run ~loc "[Graph.add_neighbour] try to build twice the \"same\" neighbour node (with label '%s')" (Label.to_string label);
......
......@@ -95,6 +95,8 @@ module G_graph: sig
val fold_gid: (Gid.t -> 'a -> 'a) -> t -> 'a -> 'a
val normalize: t -> t
(** raise ??? *)
val max_binding: t -> int
......
......@@ -136,6 +136,7 @@ module Modul = struct
type t = {
name: string;
local_labels: (string * string list) array;
suffixes: string list;
rules: Rule.t list;
filters: Rule.t list;
confluent: bool;
......@@ -154,14 +155,16 @@ module Modul = struct
let build ast_module =
let locals = Array.of_list ast_module.Ast.local_labels in
Array.sort compare locals;
let rules_or_filters = List.map (Rule.build ~locals ast_module.Ast.mod_dir) ast_module.Ast.rules in
let suffixes = ast_module.Ast.suffixes in
let rules_or_filters = List.map (Rule.build ~locals suffixes ast_module.Ast.mod_dir) ast_module.Ast.rules in
let (filters, rules) = List.partition Rule.is_filter rules_or_filters in
let modul =
{
name = ast_module.Ast.module_id;
local_labels = locals;
rules = rules;
filters = filters;
suffixes;
rules;
filters;
confluent = ast_module.Ast.confluent;
loc = ast_module.Ast.mod_loc;
} in
......@@ -260,7 +263,9 @@ module Grs = struct
Timeout.start ();
let modules_to_apply = modules_of_sequence grs sequence in
let rec loop instance = function
let rec loop instance module_list =
let instance = {instance with Instance.graph = G_graph.normalize instance.Instance.graph} in
match module_list with
| [] -> (* no more modules to apply *)
{Rewrite_history.instance = instance; module_name = ""; good_nf = []; bad_nf = []; }
| next::tail ->
......@@ -284,7 +289,9 @@ module Grs = struct
let build_rew_display grs sequence instance =
let modules_to_apply = modules_of_sequence grs sequence in
let rec loop instance = function
let rec loop instance module_list =
let instance = {instance with Instance.graph = G_graph.normalize instance.Instance.graph} in
match module_list with
| [] -> Grew_types.Leaf instance.Instance.graph
| next :: tail ->
let (good_set, bad_set) =
......
......@@ -13,10 +13,11 @@ open Grew_graph
open Grew_rule
open Grew_ast
(* ==================================================================================================== *)
module Rewrite_history: sig
type t = {
instance: Instance.t;
module_name: string;
module_name: string;
good_nf: t list;
bad_nf: Instance.t list;
}
......@@ -24,17 +25,17 @@ module Rewrite_history: sig
val is_empty: t -> bool
val num_sol: t -> int
(** [save_nfs ?main_feat base_name t] does two things:
- write PNG files of normal forms
- returns a list of couples (rules, file)
*)
val save_nfs:
?filter: string list ->
?main_feat: string ->
?filter: string list ->
?main_feat: string ->
dot: bool ->
string ->
t ->
string ->
t ->
((string * string list) list * string) list
(** [save_annot out_dir base_name t] writes a set of svg_file for an annotation folder. *)
......@@ -55,10 +56,12 @@ module Rewrite_history: sig
val conll_dep_string: ?keep_empty_rh:bool -> t -> string option
end
(* ==================================================================================================== *)
module Modul: sig
type t = {
name: string;
local_labels: (string * string list) array;
suffixes: string list;
rules: Rule.t list;
filters: Rule.t list;
confluent: bool;
......@@ -66,13 +69,12 @@ module Modul: sig
}
end
(* ==================================================================================================== *)
module Grs: sig
type t
val empty:t
val get_modules: t -> Modul.t list
val get_ast: t -> Ast.grs
......
......@@ -259,7 +259,7 @@ module Rule = struct
Buffer.contents buff
(* ====================================================================== *)
let build_commands ?param ?(locals=[||]) pos pos_table ast_commands =
let build_commands ?param ?(locals=[||]) suffixes pos pos_table ast_commands =
let known_act_ids = List.map (fun x -> (x,None)) (Array.to_list pos_table) in
let known_edge_ids = get_edge_ids pos in
......@@ -272,6 +272,7 @@ module Rule = struct
(kai,kei)
pos_table
locals
suffixes
ast_command in
command :: (loop (new_kai,new_kei) tail) in
loop (known_act_ids, known_edge_ids) ast_commands
......@@ -290,7 +291,7 @@ module Rule = struct
parse_pat_vars vars
(* ====================================================================== *)
let build ?(locals=[||]) dir rule_ast =
let build ?(locals=[||]) suffixes dir rule_ast =
let (param, pat_vars, cmd_vars) =
match rule_ast.Ast.param with
......@@ -317,7 +318,7 @@ module Rule = struct
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;
commands = build_commands ~param:(pat_vars,cmd_vars) ~locals pos pos_table rule_ast.Ast.commands;
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;
param_names = (pat_vars,cmd_vars)
......@@ -696,6 +697,7 @@ module Rule = struct
},
(created_nodes, ((pid, new_name), new_gid) :: activated_nodes)
)
| Command.ACT_NODE _ -> Error.bug "Try to activate a node without suffix" (Loc.to_string loc)
| Command.SHIFT_IN (src_cn,tar_cn) ->
let src_gid = node_find src_cn in
......
......@@ -74,7 +74,7 @@ module Rule : sig
(** [build ?local dir ast_rule] returns the Rule.t value corresponding to [ast_rule].
[dir] is used for localisation of lp files *)
val build: ?locals:Label.decl array -> string -> Ast.rule -> t
val build: ?locals:Label.decl array -> string list -> string -> Ast.rule -> t
(** [normalize module_name ?confluent rule_list filter_list instance] returns two sets of good normal forms and bad normal forms *)
(* raise Stop if some command fails to apply *)
......
......@@ -522,7 +522,7 @@ module Massoc_make (Ord: OrderedType) = struct
| [one] when one=value -> M.remove key t
| old -> M.add key (List_.usort_remove value old) t
let rec remove_key key t = M.remove key t
let remove_key key t = M.remove key t
let rec mem key value t =
try List_.sort_mem value (M.find key t)
......
......@@ -62,7 +62,7 @@ let localize t = (t,get_loc ())
%token FEATURE /* feature */
%token FILE /* file */
%token LABELS /* labels */
%token NEW_NODES /* new_nodes */
%token SUFFIXES /* suffixes */
%token ACTIVATE /* activate */
%token MATCH /* match */
%token WITHOUT /* without */
......@@ -249,11 +249,11 @@ modules:
| x=list(grew_module) { x }
grew_module:
| doc=option(COMMENT) MODULE conf=boption(CONFLUENT) id_loc=simple_id_with_loc LACC l=option(labels) nn=option(new_nodes) r=rules RACC
| doc=option(COMMENT) MODULE conf=boption(CONFLUENT) id_loc=simple_id_with_loc LACC l=option(labels) suff=option(suffixes) r=rules RACC
{
{ Ast.module_id = fst id_loc;
local_labels = (match l with None -> [] | Some x -> x);
new_node_names = (match nn with None -> [] | Some x -> x);
suffixes = (match suff with None -> [] | Some x -> x);
rules = r;
confluent = conf;
module_doc = (match doc with Some d -> d | None -> []);
......@@ -262,9 +262,9 @@ grew_module:
}
}
new_nodes:
(* "new_nodes {a, b, c}" *)
| NEW_NODES x=delimited(LACC,separated_nonempty_list_final_opt(COMA,COMPLEX_ID),RACC)
suffixes:
(* "suffixes {a, b, c}" *)
| SUFFIXES x=delimited(LACC,separated_nonempty_list_final_opt(COMA,COMPLEX_ID),RACC)
{ List.map Ast.simple_id_of_ci x }
......
......@@ -105,7 +105,7 @@ and global = parse
| "feature" { FEATURE }
| "file" { FILE }
| "labels" { LABELS }
| "new_nodes" { NEW_NODES }
| "suffixes" { SUFFIXES }
| "match" { MATCH }
| "without" { WITHOUT }
| "commands" { COMMANDS }
......
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