Commit 066dcb37 authored by bguillaum's avatar bguillaum

New declaration of add_node

PREC and SUCC rels printed only in debug mode

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8965 7838e531-6607-4d57-9587-6c381814729c
parent 5f7c38c3
......@@ -188,6 +188,11 @@ module Ast = struct
| String_item of string
| Param_item of string
let string_of_concat_item = function
| Qfn_item id -> sprintf "%s" (dump_feature_ident id)
| String_item s -> sprintf "\"%s\"" s
| Param_item var -> sprintf "%s" var
type u_command =
| Del_edge_expl of (Id.name * Id.name * edge_label)
| Del_edge_name of string
......@@ -200,12 +205,61 @@ module Ast = struct
| Merge_node of (Id.name * Id.name)
| New_neighbour of (Id.name * Id.name * edge_label)
| New_node of Id.name
| New_before of (Id.name * Id.name)
| New_after of (Id.name * Id.name)
| Del_node of Id.name
| Del_feat of feature_ident
| Update_feat of feature_ident * concat_item list
type command = u_command * Loc.t
let string_of_u_command u_command = match u_command with
| Del_edge_expl (n1,n2,label) ->
sprintf "del_edge %s -[%s]-> %s" n1 label n2
| Del_edge_name name -> sprintf "del_edge %s" name
| Add_edge (n1,n2,label) ->
sprintf "add_edge %s -[%s]-> %s" n1 label n2
| Shift_in (n1,n2,([],true)) ->
sprintf "shift_in %s ==> %s" n1 n2
| Shift_in (n1,n2,(labels,false)) ->
sprintf "shift_in %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_in (n1,n2,(labels,true)) ->
sprintf "shift_in %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_out (n1,n2,([],true)) ->
sprintf "shift_out %s ==> %s" n1 n2
| Shift_out (n1,n2,(labels,false)) ->
sprintf "shift_out %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_out (n1,n2,(labels,true)) ->
sprintf "shift_out %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_edge (n1,n2,([],true)) ->
sprintf "shift %s ==> %s" n1 n2
| Shift_edge (n1,n2,(labels,false)) ->
sprintf "shift %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_edge (n1,n2,(labels,true)) ->
sprintf "shift %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Merge_node (n1,n2) -> sprintf "merge %s ==> %s" n1 n2
| New_neighbour (n1,n2,label) -> sprintf "add_node %s: <-[%s]- %s" n1 label n2
| New_node (n) -> sprintf "add_node %s" n
| New_before (n1,n2) -> sprintf "add_node %s :< %s" n1 n2
| New_after (n1,n2) -> sprintf "add_node %s :> %s" n1 n2
| Del_node act_id -> sprintf "del_node %s" act_id
| Update_feat ((act_id, feat_name),item_list) ->
sprintf "%s.%s = %s" act_id feat_name (List_.to_string string_of_concat_item " + " item_list)
| Del_feat (act_id, feat_name) ->
sprintf "del_feat %s.%s" act_id feat_name
let rec replace_new_neighbour = function
| [] -> []
| (New_neighbour (new_name, old_name, edge),loc) :: tail ->
(New_after (new_name, old_name),loc) :: (Add_edge (old_name, new_name, edge),loc) :: (replace_new_neighbour tail)
| head :: tail -> head :: (replace_new_neighbour tail)
(* the [rule] type is used for 3 kinds of module items:
- rule { param=None; ... }
- lex_rule
......
......@@ -123,12 +123,22 @@ module Ast : sig
| Merge_node of (Id.name * Id.name)
| New_neighbour of (Id.name * Id.name * edge_label)
| New_node of Id.name
| New_before of (Id.name * Id.name)
| New_after of (Id.name * Id.name)
| Del_node of Id.name
| Del_feat of feature_ident
| Update_feat of feature_ident * concat_item list
val string_of_u_command: u_command -> string
type command = u_command * Loc.t
val replace_new_neighbour: command list -> command list
type rule = {
rule_id:Id.name;
pattern: pattern;
......
......@@ -601,6 +601,7 @@ module Global = struct
let current_file = ref "Not a file"
let current_line = ref 1
let label_flag = ref false
let debug = ref false
let init file =
current_file := file;
......
......@@ -277,4 +277,6 @@ module Global: sig
val current_line: int ref
val init: string -> unit
val label_flag: bool ref
val debug: bool ref
end
......@@ -40,6 +40,11 @@ module Command = struct
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t) (* TODO: remove *)
| NEW_NODE of string
| NEW_BEFORE of (string * command_node)
| NEW_AFTER of (string * command_node)
| SHIFT_EDGE of (command_node * command_node * Label_cst.t)
| SHIFT_IN of (command_node * command_node * Label_cst.t)
| SHIFT_OUT of (command_node * command_node * Label_cst.t)
......@@ -56,11 +61,17 @@ module Command = struct
| H_DEL_FEAT of (Gid.t * string)
| H_UPDATE_FEAT of (Gid.t * string * string)
| H_NEW_NEIGHBOUR of (string * G_edge.t * Gid.t) (* TODO: remove *)
| H_NEW_NODE of string
| H_NEW_BEFORE of (string * Gid.t)
| H_NEW_AFTER of (string * Gid.t)
| H_SHIFT_EDGE of (Gid.t * Gid.t)
| H_SHIFT_IN of (Gid.t * Gid.t)
| H_SHIFT_OUT of (Gid.t * Gid.t)
| H_MERGE_NODE of (Gid.t * Gid.t)
let build domain label_domain ?param (kai, kei) table locals ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *)
......@@ -140,6 +151,23 @@ module Command = struct
(Loc.to_string loc)
end
| (Ast.New_node new_id, loc) ->
if List.mem new_id kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
(((NEW_NODE new_id), loc),(new_id::kai, kei))
| (Ast.New_before (new_id, old_id), loc) ->
check_node_id loc old_id kai;
if List.mem new_id kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
((NEW_BEFORE (new_id,pid_of_act_id loc old_id), loc),(new_id::kai, kei))
| (Ast.New_after (new_id, old_id), loc) ->
check_node_id loc old_id kai;
if List.mem new_id kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
((NEW_AFTER (new_id,pid_of_act_id loc old_id), loc),(new_id::kai, kei))
| (Ast.Del_node act_n, loc) ->
check_node_id loc act_n kai;
((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
......
......@@ -34,6 +34,11 @@ module Command : sig
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| NEW_NODE of string
| NEW_BEFORE of (string * command_node)
| NEW_AFTER of (string * command_node)
| SHIFT_EDGE of (command_node * command_node * Label_cst.t)
| SHIFT_IN of (command_node * command_node * Label_cst.t)
| SHIFT_OUT of (command_node * command_node * Label_cst.t)
......@@ -48,6 +53,11 @@ module Command : sig
| H_DEL_FEAT of (Gid.t *string)
| H_UPDATE_FEAT of (Gid.t * string * string)
| H_NEW_NEIGHBOUR of (string * G_edge.t * Gid.t)
| H_NEW_NODE of string
| H_NEW_BEFORE of (string * Gid.t)
| H_NEW_AFTER of (string * Gid.t)
| H_SHIFT_EDGE of (Gid.t * Gid.t)
| H_SHIFT_IN of (Gid.t * Gid.t)
| H_SHIFT_OUT of (Gid.t * Gid.t)
......
......@@ -306,8 +306,8 @@ module G_fs = struct
| [] -> "_"
| l -> String.concat "#" l in
let last = match (filter, position) with
| (Some l, Some f) when List.mem "position" l && f > 0. -> [G_feature.to_string ("position", Float f)]
let last = match (!Global.debug, position) with
| (true, Some f) -> [(G_feature.to_string ("position", Float f))^":B:lightblue"]
| _ -> [] in
let lines = List.fold_left
......
This diff is collapsed.
......@@ -90,7 +90,9 @@ module G_graph: sig
val normalize: t -> t
(** raise ??? *)
val get_highest: t -> int
(** TODO REMOVE ??? *)
val max_binding: t -> int
(** [edge_out label_domain t id label_cst] returns true iff there is an out-edge from the node [id] with a label compatible with [label_cst] *)
......@@ -137,6 +139,9 @@ module G_graph: sig
val add_neighbour: Loc.t -> Domain.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t)
val add_before: Loc.t -> Domain.t -> Gid.t -> t -> (Gid.t * t)
val add_after: Loc.t -> Domain.t -> Gid.t -> t -> (Gid.t * t)
val merge_node: Loc.t -> Domain.t -> t -> Gid.t -> Gid.t -> t option
(** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
......
......@@ -49,42 +49,7 @@ module Html_doc = struct
let buff_html_command ?(li_html=false) buff (u_command,_) =
bprintf buff " ";
if li_html then bprintf buff "<li>";
(match u_command with
| Ast.Del_edge_expl (n1,n2,label) ->
bprintf buff "del_edge %s -[%s]-> %s" n1 label n2
| Ast.Del_edge_name name -> bprintf buff "del_edge %s" name
| Ast.Add_edge (n1,n2,label) ->
bprintf buff "add_edge %s -[%s]-> %s" n1 label n2
| Ast.Shift_in (n1,n2,([],true)) ->
bprintf buff "shift_in %s ==> %s" n1 n2
| Ast.Shift_in (n1,n2,(labels,false)) ->
bprintf buff "shift_in %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_in (n1,n2,(labels,true)) ->
bprintf buff "shift_in %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_out (n1,n2,([],true)) ->
bprintf buff "shift_out %s ==> %s" n1 n2
| Ast.Shift_out (n1,n2,(labels,false)) ->
bprintf buff "shift_out %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_out (n1,n2,(labels,true)) ->
bprintf buff "shift_out %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_edge (n1,n2,([],true)) ->
bprintf buff "shift %s ==> %s" n1 n2
| Ast.Shift_edge (n1,n2,(labels,false)) ->
bprintf buff "shift %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Ast.Shift_edge (n1,n2,(labels,true)) ->
bprintf buff "shift %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Ast.Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" n1 n2
| Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s" n1 label n2
| Ast.Del_node act_id -> bprintf buff "del_node %s" act_id
| Ast.Update_feat ((act_id, feat_name),item_list) ->
bprintf buff "%s.%s = %s" act_id feat_name (List_.to_string string_of_concat_item " + " item_list)
| Ast.Del_feat (act_id, feat_name) ->
bprintf buff "del_feat %s.%s" act_id feat_name
);
bprintf buff "%s" (Ast.string_of_u_command u_command);
if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
let html_feature (u_feature,_) =
......
......@@ -206,6 +206,10 @@ and standard target = parse
| "<<" { LPREC }
| ">>" { LSUCC }
| ":<" { BEFORE }
| ":>" { AFTER }
| "<" { LT }
| ">" { GT }
| "<=" | "≤" { LE }
......
......@@ -41,6 +41,9 @@ module G_node = struct
let get_prec t = t.prec
let get_succ t = t.succ
let set_succ id t = { t with succ = Some id }
let set_prec id t = { t with prec = Some id }
let empty = { fs = G_fs.empty; next = Massoc_gid.empty; succ = None; prec = None; position = -1.; conll_root=false }
let is_conll_root t = t.conll_root
......@@ -61,19 +64,17 @@ module G_node = struct
let get_annot_info t = G_fs.get_annot_info t.fs
let build domain ?def_position (ast_node, loc) =
let build domain ?prec ?succ position (ast_node, loc) =
let fs = G_fs.build domain ast_node.Ast.fs in
let position = match (ast_node.Ast.position, def_position) with
| (Some position, _) -> position
| (None, Some position) -> position
| (None, None) -> Error.bug "Cannot build a node without position" in
(ast_node.Ast.node_id, { empty with fs; position })
(ast_node.Ast.node_id, { empty with fs; position = float_of_int position; prec; succ })
let of_conll ?loc ?prec ?succ domain line =
if line = Conll.root
then { empty with conll_root=true }
else { empty with fs = G_fs.of_conll ?loc domain line; position = float line.Conll.id; prec; succ }
let fresh domain ?prec ?succ position = { empty with position; prec; succ }
let remove (id_tar : Gid.t) label t = {t with next = Massoc_gid.remove id_tar label t.next}
let remove_key node_id t =
......
......@@ -31,6 +31,9 @@ module G_node: sig
val get_succ: t -> Gid.t option
val get_prec: t -> Gid.t option
val set_prec: Gid.t -> t -> t
val set_succ: Gid.t -> t -> t
val set_fs: G_fs.t -> t -> t
val set_position: float -> t -> t
val set_next: G_edge.t Massoc_gid.t -> t -> t
......@@ -47,8 +50,9 @@ module G_node: sig
val rm_out_edges: t -> t
val add_edge: G_edge.t -> Gid.t -> t -> t option
val build: Domain.t -> ?def_position: float -> Ast.node -> (Id.name * t)
val build: Domain.t -> ?prec:Gid.t -> ?succ:Gid.t -> int -> Ast.node -> (Id.name * t)
val of_conll: ?loc:Loc.t -> ?prec:Gid.t -> ?succ:Gid.t -> Domain.t -> Conll.line -> t
val fresh: Domain.t -> ?prec:Gid.t -> ?succ:Gid.t -> float -> t
val get_position: t -> float
......
......@@ -55,6 +55,9 @@ let localize t = (t,get_loc ())
%token LPREC /* << */
%token LSUCC /* >> */
%token BEFORE /* :< */
%token AFTER /* :> */
%token PIPE /* | */
%token EDGE /* -> */
......@@ -311,7 +314,7 @@ rule:
{
{ Ast.rule_id = fst id_loc;
pattern = Ast.complete_pattern { Ast.pat_pos = p; Ast.pat_negs = n };
commands = cmds;
commands = Ast.replace_new_neighbour cmds;
param = None;
lex_par = None;
rule_doc = begin match doc with Some d -> d | None -> [] end;
......@@ -384,7 +387,6 @@ pat_node:
node_features:
(* "cat = n|v|adj" *)
(* "cat = *" *)
| name_loc=simple_id_with_loc EQUAL values=separated_nonempty_list(PIPE,feature_value)
{ let (name,loc) = name_loc in
match values with
......@@ -395,6 +397,10 @@ node_features:
| name_loc=simple_id_with_loc EQUAL STAR
{ let (name,loc) = name_loc in ({Ast.kind = Ast.Disequality []; name},loc) }
(* "cat" *)
| name_loc=simple_id_with_loc
{ let (name,loc) = name_loc in ({Ast.kind = Ast.Disequality []; name},loc) }
(* "cat<>n|v|adj" *)
| name_loc=simple_id_with_loc DISEQUAL values=separated_nonempty_list(PIPE,feature_value)
{ let (name,loc) = name_loc in ( {Ast.kind = Ast.Disequality values; name}, loc) }
......@@ -604,6 +610,18 @@ command:
| ADD_NODE new_ci_loc=simple_id_with_loc DDOT label=delimited(RTL_EDGE_LEFT,label_ident,RTL_EDGE_RIGHT) anc_ci=simple_id
{ let (new_ci,loc) = new_ci_loc in (Ast.New_neighbour (new_ci, anc_ci,label), loc) }
(* add_node n *)
| ADD_NODE new_ci_loc=simple_id_with_loc
{ let (new_ci,loc) = new_ci_loc in (Ast.New_node new_ci, loc) }
(* add_node n :< m *)
| ADD_NODE new_ci_loc=simple_id_with_loc BEFORE old_ci=simple_id
{ let (new_ci,loc) = new_ci_loc in (Ast.New_before (new_ci,old_ci), loc) }
(* add_node n :> m *)
| ADD_NODE new_ci_loc=simple_id_with_loc AFTER old_ci=simple_id
{ let (new_ci,loc) = new_ci_loc in (Ast.New_after (new_ci,old_ci), loc) }
(* del_feat m.cat *)
| DEL_FEAT com_fead_id_loc= feature_ident_with_loc
{ let (com_fead_id,loc) = com_fead_id_loc in (Ast.Del_feat com_fead_id, loc) }
......
......@@ -32,15 +32,15 @@ module Instance = struct
history: Command.h list;
rules: string list;
big_step: Libgrew_types.big_step option;
free_index: int;
highest_index: int;
}
let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; free_index=0; }
let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; highest_index=0; }
let from_graph graph =
{empty with
graph = graph;
free_index = (G_graph.max_binding graph) + 1;
highest_index = (G_graph.max_binding graph) + 1;
}
let rev_steps t =
......@@ -59,8 +59,8 @@ module Instance = struct
(node_id, Gid.Old next_free) :: acc_map,
next_free + 1
)
) ([], t.free_index) t.actiiivated_node in
{ empty with graph = G_graph.rename mapping t.graph; free_index = new_free }
) ([], t.highest_index) t.actiiivated_node in
{ empty with graph = G_graph.rename mapping t.graph; highest_index = new_free }
*)
(* comparison is done on the list of commands *)
......@@ -813,6 +813,39 @@ module Rule = struct
(created_name,new_gid) :: created_nodes
)
| Command.NEW_AFTER (created_name,base_cn) ->
let base_gid = node_find base_cn in
let (new_gid,new_graph) = G_graph.add_after loc domain base_gid instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_NEW_AFTER (created_name,new_gid)) instance.Instance.history;
},
(created_name,new_gid) :: created_nodes
)
| Command.NEW_NODE (created_name) ->
let base_gid = Gid.Old (G_graph.get_highest instance.Instance.graph) in
let (new_gid,new_graph) = G_graph.add_after loc domain base_gid instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_NEW_AFTER (created_name,new_gid)) instance.Instance.history;
},
(created_name,new_gid) :: created_nodes
)
| Command.NEW_BEFORE (created_name,base_cn) ->
let base_gid = node_find base_cn in
let (new_gid,new_graph) = G_graph.add_before loc domain base_gid instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_NEW_BEFORE (created_name,new_gid)) instance.Instance.history;
},
(created_name,new_gid) :: created_nodes
)
| Command.SHIFT_IN (src_cn,tar_cn,label_cst) ->
let src_gid = node_find src_cn in
let tar_gid = node_find tar_cn in
......
......@@ -24,7 +24,7 @@ module Instance : sig
history: Command.h list;
rules: string list;
big_step: Libgrew_types.big_step option;
free_index: int;
highest_index: int;
}
(** [from_graph graph] return a fresh instance based on the input [graph]. *)
......
......@@ -12,6 +12,8 @@ open Printf
open Log
open Conll
let libgrew_debug_mode () = Grew_base.Global.debug := true
(* ==================================================================================================== *)
(** {2 Location} *)
(* ==================================================================================================== *)
......
......@@ -10,6 +10,8 @@
open Conll
val libgrew_debug_mode: unit -> unit
(* ==================================================================================================== *)
(** {2 Location} *)
(* ==================================================================================================== *)
......
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