Commit 82c97dcc authored by bguillaum's avatar bguillaum

- fix bug whit several declaration of the same node

- check grs cosistency when loading

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@6690 7838e531-6607-4d57-9587-6c381814729c
parent 1e4c000f
......@@ -44,35 +44,50 @@ module Command = struct
| H_SHIFT_EDGE of (gid * gid)
| H_MERGE_NODE of (gid * gid)
let build ?domain table locals ast_command =
let build ?domain (kni, kei) table locals ast_command =
let get_pid node_name =
match Id.build_opt node_name table with
| Some id -> Pid id
| None -> New node_name in
let check_node loc node_id kni =
if not (List.mem node_id kni)
then Error.build ~loc "Unbound node identifier \"%s\"" node_id in
let check_edge loc edge_id kei =
if not (List.mem edge_id kei)
then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in
match ast_command with
| (Ast.Del_edge_expl (i, j, lab), loc) ->
check_node loc i kni; check_node loc j kni;
let edge = Edge.make ~locals [lab] in
(DEL_EDGE_EXPL (get_pid i, get_pid j, edge), loc)
((DEL_EDGE_EXPL (get_pid i, get_pid j, edge), loc), (kni, kei))
| (Ast.Del_edge_name id, loc) ->
(DEL_EDGE_NAME id, loc)
check_edge loc id kei;
(DEL_EDGE_NAME id, loc), (kni, List_.rm id kei)
| (Ast.Add_edge (i, j, lab), loc) ->
check_node loc i kni; check_node loc j kni;
let edge = Edge.make ~locals [lab] in
(ADD_EDGE (get_pid i, get_pid j, edge), loc)
((ADD_EDGE (get_pid i, get_pid j, edge), loc), (kni, kei))
| (Ast.Shift_edge (i, j), loc) ->
(SHIFT_EDGE (get_pid i, get_pid j), loc)
check_node loc i kni; check_node loc j kni;
((SHIFT_EDGE (get_pid i, get_pid j), loc), (kni, kei))
| (Ast.Merge_node (i, j), loc) ->
(MERGE_NODE (get_pid i, get_pid j), loc)
check_node loc i kni; check_node loc j kni;
((MERGE_NODE (get_pid i, get_pid j), loc), (List_.rm i kni, kei))
| (Ast.New_neighbour (name_created, ancestor, label), loc) ->
check_node loc ancestor kni;
if List.mem name_created kni
then Error.build ~loc "Node identifier \"%s\" is already used" name_created;
let edge = Edge.make ~locals [label] in
begin
try (NEW_NEIGHBOUR (name_created, edge, Id.build ~loc ancestor table), loc)
try ((NEW_NEIGHBOUR (name_created, edge, Id.build ~loc ancestor table), loc), (name_created::kni, kei))
with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(Edge.to_string edge)
......@@ -80,17 +95,22 @@ module Command = struct
(Loc.to_string loc)
end
| (Ast.Del_node n, loc) ->
(DEL_NODE (get_pid n), loc)
| (Ast.Del_node n, loc) ->
check_node loc n kni;
((DEL_NODE (get_pid n), loc), (List_.rm n kni, kei))
| (Ast.Del_feat (node,feat_name), loc) ->
(DEL_FEAT (get_pid node, feat_name), loc)
check_node loc node kni;
((DEL_FEAT (get_pid node, feat_name), loc), (kni, kei))
| (Ast.Update_feat ((tar_node, tar_feat_name), ast_items), loc) ->
check_node loc tar_node kni;
let items = List.map
(function
| Ast.Qfn_item (node,feat_name) -> Feat (get_pid node, feat_name)
| Ast.Qfn_item (node,feat_name) -> check_node loc node kni; Feat (get_pid node, feat_name)
| Ast.String_item s -> String s)
ast_items in
(UPDATE_FEAT (get_pid tar_node, tar_feat_name, items), loc)
((UPDATE_FEAT (get_pid tar_node, tar_feat_name, items), loc), (kni, kei))
end
......@@ -38,6 +38,12 @@ module Command : sig
| H_SHIFT_EDGE of (gid * gid)
| H_MERGE_NODE of (gid * gid)
val build: ?domain:Ast.domain -> Id.table -> Label.decl array -> Ast.command -> t
val build:
?domain:Ast.domain ->
(string list * string list) ->
Id.table ->
Label.decl array ->
Ast.command ->
t * (string list * string list)
end
......@@ -27,6 +27,7 @@ module Graph = struct
let empty = {map = IntMap.empty; lub = 0}
type gid = int
type concat_item =
| Feat of (gid * string)
| String of string
......@@ -50,9 +51,25 @@ module Graph = struct
| Some new_map -> Some {graph with map = new_map}
| None -> None
let build_filter ?domain table (ast_node, loc) =
let pid = Id.build ~loc ast_node.Ast.node_id table in
let fs = Feature_structure.build ?domain ast_node.Ast.fs in
(pid, fs)
let build ?domain ?(locals=[||]) full_node_list full_edge_list =
let named_nodes = List.map (Node.build ?domain) full_node_list in
let (named_nodes, constraints) =
let rec loop already_bound = function
| [] -> ([],[])
| (ast_node, loc) :: tail ->
let (tail_nodes, tail_const) = loop (ast_node.Ast.node_id :: already_bound) tail in
if List.mem ast_node.Ast.node_id already_bound
then (tail_nodes, (ast_node, loc)::tail_const)
else (Node.build ?domain (ast_node, loc) :: tail_nodes, tail_const) in
loop [] full_node_list in
(* let named_nodes = List.map (Node.build ?domain) full_node_list in *)
let sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) named_nodes in
let (sorted_ids, node_list) = List.split sorted_nodes in
......@@ -77,19 +94,23 @@ module Graph = struct
)
) map_without_edges full_edge_list in
({map=map;lub=Array.length table}, table)
({map=map;lub=Array.length table}, table, List.map (build_filter ?domain table) constraints)
(* a type for extension of graph: a former graph exists: in grew the former is a positive pattern and an extension is a "without" *)
(* a type for extension of graph: a former graph exists:
in grew the former is a positive pattern and an extension is a "without" *)
type extention = {
ext_map: Node.t IntMap.t; (* node description for new nodes and for edge "Old -> New" *)
old_map: Node.t IntMap.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
let build_extention ?domain ?(locals=[||]) old_table full_node_list full_edge_list =
let built_nodes = List.map (Node.build ?domain) full_node_list in
let (old_nodes, new_nodes) = List.partition (function (id,_) when Array_.dicho_mem id old_table -> true | _ -> false) built_nodes in
let (old_nodes, new_nodes) =
List.partition
(function (id,_) when Array_.dicho_mem id old_table -> true | _ -> false)
built_nodes in
let new_sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) new_nodes in
......@@ -251,8 +272,14 @@ module Graph = struct
(* remove (id_src -[label]-> id_tar) from graph.
Log.critical if the edge is not in graph *)
let del_edge loc graph id_src label id_tar =
let node_src = IntMap.find id_src graph.map in
let del_edge ?edge_ident loc graph id_src label id_tar =
let node_src =
try IntMap.find id_src graph.map
with Not_found ->
match edge_ident with
| None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report"
| Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in
try {graph with map =
IntMap.add id_src {node_src with Node.next = Massoc.remove id_tar label node_src.Node.next} graph.map
}
......
open Ast
open Grew_fs
open Grew_edge
open Grew_node
open Utils
......@@ -32,7 +33,7 @@ module Graph : sig
?locals: Label.decl array ->
Ast.node list ->
Ast.edge list ->
(t * Id.table)
(t * Id.table * (Id.t * Feature_structure.t) list )
(* a type for extension of graph: a former graph exists: in grew the former is a positive pattern and an extension is a "without" *)
type extention = {
......@@ -54,7 +55,7 @@ module Graph : sig
val to_dep: ?main_feat:string -> ?deco:Deco.t -> t -> string
val add_edge : t -> int -> Edge.t -> int -> t option
val del_edge : Loc.t -> t -> int -> Edge.t -> int -> t
val del_edge : ?edge_ident: string -> Loc.t -> t -> int -> Edge.t -> int -> t
val del_node : t -> int -> t
val add_neighbour : Loc.t -> t -> int -> Edge.t -> (int * t)
......
......@@ -42,6 +42,8 @@ module Edge = struct
under_label: under_label;
}
let get_id t = t.id
let all = {id=None; under_label=Neg []}
let compare = Pervasives.compare
......
......@@ -20,6 +20,8 @@ module Edge : sig
val as_label: t -> Label.t
val of_label: Label.t -> t
val get_id: t -> string option
(* [all] is the joker pattern edge *)
val all: t
......
......@@ -15,7 +15,7 @@ type rule_app = {
type rew_display =
| Empty (* pour les besoin du dev *)
| Leaf of Graph.t
| Local_normal_form of Graph.t * module_name * rew_display
| Local_normal_form of Graph.t * module_name * rew_display
| Node of Graph.t * module_name * (big_step * rew_display) list
(* the type for big edges which correspond the a module *)
......
......@@ -20,7 +20,7 @@ type rule_app = {
type rew_display =
| Empty (* pour les besoin du dev *)
| Leaf of graph
| Local_normal_form of graph * module_name * rew_display
| Local_normal_form of graph * module_name * rew_display
| Node of graph * module_name * (big_step * rew_display) list
(** the type for big edges which correspond the a module *)
......
......@@ -149,19 +149,56 @@ module Modul = struct
bad_labels: Label.t list;
rules: Rule.t list;
confluent: bool;
loc: Loc.t;
}
let check t =
(* check for duplicate rules *)
let rec loop already_defined = function
| [] -> ()
| r::_ when List.mem (Rule.get_name r) already_defined ->
Error.build ~loc:(Rule.get_loc r) "Rule '%s' is defined twice in the same module" (Rule.get_name r)
| r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
loop [] t.rules
let build ?domain ast_module =
let locals = Array.of_list ast_module.Ast.local_labels in
Array.sort compare locals;
{
name = ast_module.Ast.module_id;
local_labels = locals;
bad_labels = List.map Label.from_string ast_module.Ast.bad_labels;
rules = List.map (Rule.build ?domain ~locals) ast_module.Ast.rules;
confluent = ast_module.Ast.confluent;
}
let modul =
{
name = ast_module.Ast.module_id;
local_labels = locals;
bad_labels = List.map Label.from_string ast_module.Ast.bad_labels;
rules = List.map (Rule.build ?domain ~locals) ast_module.Ast.rules;
confluent = ast_module.Ast.confluent;
loc = ast_module.Ast.mod_loc;
} in
check modul; modul
end
module Sequence = struct
type t = {
name: string;
def: string list;
loc: Loc.t;
}
let check module_list t =
List.iter
(fun module_name ->
if not (List.exists (fun modul -> modul.Modul.name = module_name) module_list)
then Error.build ~loc:t.loc "sequence \"%s\", refers to the unknown module \"%s\"."
t.name module_name
) t.def
let build module_list ast_sequence =
let sequence =
{
name = ast_sequence.Ast.seq_name;
def = ast_sequence.Ast.seq_mod;
loc = ast_sequence.Ast.seq_loc;
} in
check module_list sequence; sequence
end
module Grs = struct
......@@ -170,24 +207,45 @@ module Grs = struct
type t = {
labels: Label.t list; (* the list of global edge labels *)
modules: Modul.t list; (* the ordered list of modules used from rewriting *)
sequences: sequence list;
sequences: Sequence.t list;
}
let sequences t = t.sequences
let sequence_names t = List.map (fun s -> s.Sequence.name) t.sequences
let empty = {labels=[]; modules=[]; sequences=[];}
let check t =
(* check for duplicate modules *)
let rec loop already_defined = function
| [] -> ()
| m::_ when List.mem m.Modul.name already_defined ->
Error.build ~loc:m.Modul.loc "Module '%s' is defined twice" m.Modul.name
| m::tail -> loop (m.Modul.name :: already_defined) tail in
loop [] t.modules;
(* check for duplicate sequences *)
let rec loop already_defined = function
| [] -> ()
| s::_ when List.mem s.Sequence.name already_defined ->
Error.build ~loc:s.Sequence.loc "Sequence '%s' is defined twice" s.Sequence.name
| s::tail -> loop (s.Sequence.name :: already_defined) tail in
loop [] t.sequences
let build ast_grs =
Label.init ast_grs.Ast.labels;
{
labels = List.map (fun (l,_) -> Label.from_string l) ast_grs.Ast.labels;
modules = List.map (Modul.build ~domain:ast_grs.Ast.domain) ast_grs.Ast.modules;
sequences = List.map (fun s -> (s.Ast.seq_name, s.Ast.seq_mod)) ast_grs.Ast.sequences;
}
Label.init ast_grs.Ast.labels;
let modules = List.map (Modul.build ~domain:ast_grs.Ast.domain) ast_grs.Ast.modules in
let grs = {
labels = List.map (fun (l,_) -> Label.from_string l) ast_grs.Ast.labels;
modules = modules;
sequences = List.map (Sequence.build modules) ast_grs.Ast.sequences;
} in
check grs; grs
let modules_of_sequence grs sequence =
let module_names =
try List.assoc sequence grs.sequences
let module_names =
try
let seq = List.find (fun s -> s.Sequence.name = sequence) grs.sequences in
seq.Sequence.def
with Not_found -> [sequence] in (* a module name can be used as a singleton sequence *)
List.map
......@@ -225,30 +283,30 @@ module Grs = struct
let rec loop instance = function
| [] -> Grew_types.Leaf instance.Instance.graph
| next :: tail ->
let (good_set, bad_set) =
| next :: tail ->
let (good_set, bad_set) =
Rule.normalize
~confluent: next.Modul.confluent
next.Modul.rules
next.Modul.rules
(fun x -> true) (* FIXME: filtering in module outputs *)
(Instance.clear instance) in
let inst_list = Instance_set.elements good_set
let inst_list = Instance_set.elements good_set
(* and bad_list = Instance_set.elements bad_set *) in
match inst_list with
| [{Instance.big_step = None}] ->
| [{Instance.big_step = None}] ->
Grew_types.Local_normal_form (instance.Instance.graph, next.Modul.name, loop instance tail)
| _ -> Grew_types.Node
| _ -> Grew_types.Node
(
instance.Instance.graph,
next.Modul.name,
List.map
(fun inst ->
List.map
(fun inst ->
match inst.Instance.big_step with
| None -> Error.bug "Cannot have no big_steps and more than one reducts at the same time"
| Some bs -> (bs, loop inst tail)
) inst_list
)
)
in loop instance modules_to_apply
end
......@@ -326,10 +384,11 @@ module Corpus_stat = struct
}
let empty ~grs ~seq =
let modules = try List.assoc seq grs.Grs.sequences with Not_found -> [seq] in
(* let modules = try List.assoc seq grs.Grs.sequences with Not_found -> [seq] in *)
let modules = Grs.modules_of_sequence grs seq in
let map = List.fold_left
(fun acc modul ->
if List.mem modul.Modul.name modules
if List.exists (fun m -> modul.Modul.name = m.Modul.name) modules
then
let rule_map =
List.fold_left
......
......@@ -21,14 +21,16 @@ IFDEF DEP2PICT THEN
ENDIF
end
module Sequence: sig
type t
end
module Grs: sig
type sequence = string * string list
type t
val empty:t
val sequences: t -> sequence list
val sequence_names: t -> string list
val build: Ast.grs -> t
......
......@@ -46,7 +46,7 @@ let load_grs ?doc_output_dir file =
| exc -> raise (Bug (sprintf "UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
let get_available_seq grs = Grs.sequences grs
let get_sequence_names grs = Grs.sequence_names grs
let empty_gr = Instance.empty
......
......@@ -45,7 +45,11 @@ val empty_grs : grs
*)
val load_grs : ?doc_output_dir:string -> string -> grs
val get_available_seq : grs -> (string * string list) list
(** give the list of sequence names defined in a GRS
@return a string list
*)
val get_sequence_names: grs -> string list
val empty_gr : gr
......
......@@ -222,7 +222,7 @@ grew_module:
rules = begin match r with None -> [] | Some r -> r; end;
confluent = conf;
module_doc = (match doc with Some d -> d | None -> "");
mod_loc = get_loc ();
mod_loc = (!Parser_global.current_file, snd id);
}
}
......@@ -341,7 +341,7 @@ feature_value:
| v = INT { string_of_int v }
pat_edge:
(* "e: A -> B" *)
(* "e: A -> B" OR "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
{ localize ({edge_id = Some id; src=n1; edge_labels=[]; tar=n2; negative=true}) }
......
......@@ -27,7 +27,8 @@ module Instance = struct
let from_graph g = {empty with graph = g}
let build gr_ast =
{ empty with graph = fst (Graph.build gr_ast.Ast.nodes gr_ast.Ast.edges) }
let (graph,_,_) = Graph.build gr_ast.Ast.nodes gr_ast.Ast.edges in
{ empty with graph = graph }
let rev_steps t =
{ t with big_step = match t.big_step with
......@@ -82,11 +83,13 @@ module Rule = struct
}
let build_pos_pattern ?domain ?(locals=[||]) pattern_ast =
let (graph,table) = Graph.build ?domain ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
let (graph,table,filter_nodes) = Graph.build ?domain ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
(
{
graph = graph;
constraints = List.map (build_constraint ~locals table) pattern_ast.Ast.pat_const ;
constraints =
List.map (build_constraint ~locals table) pattern_ast.Ast.pat_const
@ (List.map (fun (pid, fs) -> Filter (pid, fs)) filter_nodes);
},
table
)
......@@ -115,30 +118,50 @@ module Rule = struct
constraints = filters @ List.map (build_neg_constraint ~locals pos_table neg_table) pattern_ast.Ast.pat_const ;
}
let get_edge_ids pattern =
IntMap.fold
(fun _ node acc ->
Massoc.fold_left
(fun acc2 _ edge -> match Edge.get_id edge with None -> acc2 | Some id -> id::acc2)
acc node.Node.next
) pattern.graph.Graph.map []
type t = {
name: string;
pos: pattern;
neg: pattern list;
commands: Command.t list;
loc: Loc.t;
}
let get_name t = t.name
let build ?domain ?(locals=[||]) rule_ast =
(* (\* DEBUG *\) Printf.printf "==<Rule.build |neg|=%d>==\n%!" (List.length rule_ast.Ast.neg_patterns); *)
let get_loc t = t.loc
let build_commands ?domain ?(locals=[||]) pos pos_table ast_commands =
let known_node_ids = Array.to_list pos_table in
let known_edge_ids = get_edge_ids pos in
let rec loop (kni,kei) = function
| [] -> []
| ast_command :: tail ->
let (command, (new_kni, new_kei)) =
Command.build ?domain (kni,kei) pos_table locals ast_command in
command :: (loop (new_kni,new_kei) tail) in
loop (known_node_ids, known_edge_ids) ast_commands
let build ?domain ?(locals=[||]) rule_ast =
let (pos,pos_table) = build_pos_pattern ?domain ~locals rule_ast.Ast.pos_pattern in
{
name = rule_ast.Ast.rule_id ;
pos = pos;
neg = List.map (fun p -> build_neg_pattern ?domain ~locals pos_table p) rule_ast.Ast.neg_patterns;
commands = List.map (Command.build ?domain pos_table locals) rule_ast.Ast.commands;
commands = build_commands ?domain ~locals pos pos_table rule_ast.Ast.commands;
loc = rule_ast.Ast.rule_loc;
}
type matching = {
n_match: gid IntMap.t; (* partial fct: pattern nodes |--> graph nodes *)
n_match: gid IntMap.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(gid*Label.t*gid)) list; (* edge matching: edge ident |--> (src,label,tar) *)
a_match: (gid*Label.t*gid) list; (* anonymous edge mached *)
}
......@@ -377,7 +400,7 @@ module Rule = struct
let edge = Edge.of_label label in
(
{instance with
Instance.graph = Graph.del_edge loc instance.Instance.graph src_gid edge tar_gid;
Instance.graph = Graph.del_edge ~edge_ident loc instance.Instance.graph src_gid edge tar_gid;
commands = List_.sort_insert (Command.H_DEL_EDGE_EXPL (src_gid,tar_gid,edge)) instance.Instance.commands
},
created_nodes
......
......@@ -36,6 +36,8 @@ module Rule : sig
val get_name: t -> string
val get_loc: t -> Loc.t
val build: ?domain:Ast.domain -> ?locals:Label.decl array -> Ast.rule -> t
(* raise Stop if some command fails to apply *)
......
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