Skip to content

L
libcaml-grew
Commit c0994a10 authored by Bruno Guillaume's avatar Bruno Guillaume
Browse files
Options

add support for n#a node names in commands

parent 5a523355
Hide whitespace changes
Inline Side-by-side
Showing with 288 additions and 224 deletions
src/grew_ast.ml
View file @ c0994a10
......@@ -23,9 +23,6 @@ module Ast = struct
type feature = u_feature * Loc.t
(* qualified feature name "A.lemma" *)
type qfn = string * string
type u_node = {
node_id: Id.name;
position: int option;
......@@ -50,14 +47,16 @@ module Ast = struct
| Le -> "≤"
| Ge -> "≥"
type feature_name = 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
| Feature_eq of (Id.name * feature_name) * (Id.name * feature_name)
| Feature_diseq of (Id.name * feature_name) * (Id.name * feature_name)
| Feature_ineq of ineq * (Id.name * feature_name) * (Id.name * feature_name)
type const = u_const * Loc.t
......@@ -67,24 +66,37 @@ module Ast = struct
pat_const: const list;
}
type graph = {
nodes: (Id.name * node) list;
edge: edge list;
}
(* the base node name and the eventual new_node extension *)
type c_ident = Id.name * string option
let c_ident_to_string (string_node, new_opt) =
match new_opt with
| None -> string_node
| Some a -> sprintf "%s#%s" string_node a
type concat_item =
| Qfn_item of (string * string)
| Qfn_item of (c_ident * feature_name)
| String_item of string
| Param_item of string
type u_command =
| Del_edge_expl of (Id.name * Id.name * string)
| Del_edge_expl of (c_ident * c_ident * string)
| Del_edge_name of string
| Add_edge of (Id.name * Id.name * string)
| Shift_in of (Id.name*Id.name)
| Shift_out of (Id.name*Id.name)
| Shift_edge of (Id.name*Id.name)
| Merge_node of (Id.name*Id.name)
| New_neighbour of (Id.name * Id.name * string)
| Del_node of Id.name
| Del_feat of qfn
| Update_feat of qfn * concat_item list
| Add_edge of (c_ident * c_ident * string)
| Shift_in of (c_ident*c_ident)
| Shift_out of (c_ident*c_ident)
| Shift_edge of (c_ident*c_ident)
| Merge_node of (c_ident*c_ident)
| New_neighbour of (c_ident * c_ident * string)
| Del_node of c_ident
| Del_feat of (c_ident * feature_name)
| Update_feat of (c_ident * feature_name) * concat_item list
type command = u_command * Loc.t
......
src/grew_ast.mli
View file @ c0994a10
......@@ -20,9 +20,6 @@ module Ast : sig
type feature = u_feature * Loc.t
(* qualified feature name "A.lemma" *)
type qfn = string * string
type u_node = {
node_id: Id.name;
position: int option;
......@@ -45,14 +42,16 @@ module Ast : sig
val string_of_ineq: ineq -> string
type feature_name = 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
| Feature_eq of (Id.name * feature_name) * (Id.name * feature_name)
| Feature_diseq of (Id.name * feature_name) * (Id.name * feature_name)
| Feature_ineq of ineq * (Id.name * feature_name) * (Id.name * feature_name)
type const = u_const * Loc.t
......@@ -62,24 +61,29 @@ module Ast : sig
pat_const: const list;
}
(* the base node name and the eventual new_node extension *)
type c_ident = Id.name * string option
val c_ident_to_string: c_ident -> string
type concat_item =
| Qfn_item of (string * string)
| Qfn_item of (c_ident * feature_name)
| String_item of string
| Param_item of string
type u_command =
| Del_edge_expl of (Id.name * Id.name * string)
| Del_edge_expl of (c_ident * c_ident * string)
| Del_edge_name of string
| Add_edge of (Id.name * Id.name * string)
| Shift_in of (Id.name*Id.name)
| Shift_out of (Id.name*Id.name)
| Shift_edge of (Id.name*Id.name)
| Merge_node of (Id.name*Id.name)
| New_neighbour of (Id.name * Id.name * string)
| Del_node of Id.name
| Del_feat of qfn
| Update_feat of qfn * concat_item list
| Add_edge of (c_ident * c_ident * string)
| Shift_in of (c_ident*c_ident)
| Shift_out of (c_ident*c_ident)
| Shift_edge of (c_ident*c_ident)
| Merge_node of (c_ident*c_ident)
| New_neighbour of (c_ident * c_ident * string)
| Del_node of c_ident
| Del_feat of (c_ident * feature_name)
| Update_feat of (c_ident * feature_name) * concat_item list
type command = u_command * Loc.t
......
src/grew_command.ml
View file @ c0994a10
......@@ -6,13 +6,12 @@ open Grew_ast
open Grew_edge
open Grew_fs
(* ==================================================================================================== *)
module Command = struct
type pid = Pid.t
type gid = Gid.t
type cnode = (* a command node is either: *)
| Pid of pid (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *)
type cnode = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *)
| Act of Pid.t * string (* a node introduced by a activate *)
type item =
| Feat of (cnode * string)
......@@ -28,7 +27,7 @@ module Command = struct
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
......@@ -38,66 +37,72 @@ module Command = struct
(* a item in the command history: command applied to a graph *)
type h =
| H_DEL_NODE of gid
| H_DEL_EDGE_EXPL of (gid * gid *G_edge.t)
| H_DEL_NODE of Gid.t
| H_DEL_EDGE_EXPL of (Gid.t * Gid.t *G_edge.t)
| H_DEL_EDGE_NAME of string
| H_ADD_EDGE of (gid * gid * G_edge.t)
| H_DEL_FEAT of (gid *string)
| H_UPDATE_FEAT of (gid * string * string)
| H_NEW_NEIGHBOUR of (string * G_edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
let build ?param (kni, kei) table locals ast_command =
let get_pid node_name =
match Id.build_opt node_name table with
| Some id -> Pid (Pid.Pos 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
| H_ADD_EDGE of (Gid.t * Gid.t * G_edge.t)
| 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_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 ?param (kci, kei) table locals ast_command =
let pid_of_c_ident = function
| (node_name, None) -> Pat (Pid.Pos (Id.build node_name table))
| (node_name, Some n) -> Act (Pid.Pos (Id.build node_name table), n) in
let check_c_ident loc c_ident kci =
if not (List.mem c_ident kci)
then Error.build ~loc "Unbound c_ident identifier \"%s\"" (Ast.c_ident_to_string c_ident) 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;
| (Ast.Del_edge_expl (i, j, lab), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
let edge = G_edge.make ~locals lab in
((DEL_EDGE_EXPL (get_pid i, get_pid j, edge), loc), (kni, kei))
((DEL_EDGE_EXPL (pid_of_c_ident i, pid_of_c_ident j, edge), loc), (kci, kei))
| (Ast.Del_edge_name id, loc) ->
| (Ast.Del_edge_name id, loc) ->
check_edge loc id kei;
(DEL_EDGE_NAME id, loc), (kni, List_.rm id kei)
(DEL_EDGE_NAME id, loc), (kci, List_.rm id kei)
| (Ast.Add_edge (i, j, lab), loc) ->
check_node loc i kni; check_node loc j kni;
| (Ast.Add_edge (i, j, lab), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
let edge = G_edge.make ~locals lab in
((ADD_EDGE (get_pid i, get_pid j, edge), loc), (kni, kei))
| (Ast.Shift_edge (i, j), loc) ->
check_node loc i kni; check_node loc j kni;
((SHIFT_EDGE (get_pid i, get_pid j), loc), (kni, kei))
((ADD_EDGE (pid_of_c_ident i, pid_of_c_ident j, edge), loc), (kci, kei))
| (Ast.Shift_in (i, j), loc) ->
check_node loc i kni; check_node loc j kni;
((SHIFT_IN (get_pid i, get_pid j), loc), (kni, kei))
| (Ast.Shift_edge (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((SHIFT_EDGE (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
| (Ast.Shift_out (i, j), loc) ->
check_node loc i kni; check_node loc j kni;
((SHIFT_OUT (get_pid i, get_pid j), loc), (kni, kei))
| (Ast.Shift_in (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((SHIFT_IN (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
| (Ast.Merge_node (i, 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
| (Ast.Shift_out (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((SHIFT_OUT (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
| (Ast.Merge_node (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((MERGE_NODE (pid_of_c_ident i, pid_of_c_ident j), loc), (List_.rm i kci, kei))
| (Ast.New_neighbour ((name_created, None), ancestor, label), loc) ->
check_c_ident loc ancestor kci;
if List.mem (name_created, None) kci
then Error.build ~loc "Node identifier \"%s\" is already used" name_created;
let edge = G_edge.make ~locals label in
begin
......@@ -106,39 +111,40 @@ module Command = struct
(NEW_NEIGHBOUR
(name_created,
edge,
Pid.Pos (Id.build ~loc ancestor table)
Pid.Pos (Id.build ~loc (fst ancestor) table)
), loc),
(name_created::kni, kei)
((name_created, None)::kci, 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"
(G_edge.to_string edge)
ancestor
(fst ancestor)
(Loc.to_string loc)
end
| (Ast.Del_node n, loc) ->
check_node loc n kni;
((DEL_NODE (get_pid n), loc), (List_.rm n kni, kei))
| (Ast.Del_node n, loc) ->
check_c_ident loc n kci;
((DEL_NODE (pid_of_c_ident n), loc), (List_.rm n kci, kei))
| (Ast.Del_feat (node,feat_name), loc) ->
check_node loc node kni;
((DEL_FEAT (get_pid node, feat_name), loc), (kni, kei))
| (Ast.Del_feat (c_ident,feat_name), loc) ->
check_c_ident loc c_ident kci;
((DEL_FEAT (pid_of_c_ident c_ident, feat_name), loc), (kci, kei))
| (Ast.Update_feat ((tar_node, tar_feat_name), ast_items), loc) ->
check_node loc tar_node kni;
| (Ast.Update_feat ((c_ident, feat_name), ast_items), loc) ->
check_c_ident loc c_ident kci;
let items = List.map
(function
| Ast.Qfn_item (node,feat_name) -> check_node loc node kni; Feat (get_pid node, feat_name)
| Ast.String_item s -> String s
| Ast.Param_item var ->
match param with
| None -> Error.build "Unknown command variable '%s'" var
| Some (par,cmd) ->
match (List_.pos var par, List_.pos var cmd) with
| (_,Some index) -> Param_out index
| (Some index,_) -> Param_in index
| _ -> Error.build "Unknown command variable '%s'" var
) ast_items in
((UPDATE_FEAT (get_pid tar_node, tar_feat_name, items), loc), (kni, kei))
end
(function
| Ast.Qfn_item (ci,fn) -> check_c_ident loc ci kci; Feat (pid_of_c_ident ci, fn)
| Ast.String_item s -> String s
| Ast.Param_item var ->
match param with
| None -> Error.build "Unknown command variable '%s'" var
| Some (par,cmd) ->
match (List_.pos var par, List_.pos var cmd) with
| (_,Some index) -> Param_out index
| (Some index,_) -> Param_in index
| _ -> Error.build "Unknown command variable '%s'" var
) ast_items in
((UPDATE_FEAT (pid_of_c_ident c_ident, feat_name, items), loc), (kci, kei))
| _ -> failwith "TODO remove with new neighbour"
end (* module Command *)
src/grew_command.mli
View file @ c0994a10
......@@ -2,13 +2,12 @@ open Grew_ast
open Grew_utils
open Grew_edge
(* ==================================================================================================== *)
module Command : sig
type pid = Pid.t
type gid = Gid.t
type cnode = (* a command node is either: *)
| Pid of pid (* a node identified in the pattern *)
| Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *)
| Act of Pid.t * string (* a node introduced by a activate *)
type item =
| Feat of (cnode * string)
......@@ -16,40 +15,39 @@ module Command : sig
| Param_in of int
| Param_out of int
type p =
type p =
| DEL_NODE of cnode
| DEL_EDGE_EXPL of (cnode * cnode *G_edge.t)
| DEL_EDGE_EXPL of (cnode * cnode *G_edge.t)
| DEL_EDGE_NAME of string
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
| MERGE_NODE of (cnode * cnode)
type t = (p * Loc.t)
type h =
| H_DEL_NODE of gid
| H_DEL_EDGE_EXPL of (gid * gid *G_edge.t)
type t = (p * Loc.t)
type h =
| H_DEL_NODE of Gid.t
| H_DEL_EDGE_EXPL of (Gid.t * Gid.t *G_edge.t)
| H_DEL_EDGE_NAME of string
| H_ADD_EDGE of (gid * gid * G_edge.t)
| H_DEL_FEAT of (gid *string)
| H_UPDATE_FEAT of (gid * string * string)
| H_NEW_NEIGHBOUR of (string * G_edge.t * gid)
| H_SHIFT_EDGE of (gid * gid)
| H_SHIFT_IN of (gid * gid)
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
| H_ADD_EDGE of (Gid.t * Gid.t * G_edge.t)
| 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_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)
val build:
val build:
?param: (string list * string list) ->
(string list * string list) ->
Id.table ->
(Ast.c_ident list * string list) ->
Id.table ->
Label.decl array ->
Ast.command ->
t * (string list * string list)
end
Ast.command ->
t * (Ast.c_ident list * string list)
end (* module Command *)
src/grew_grs.ml
View file @ c0994a10
......@@ -9,9 +9,8 @@ open Grew_command
open Grew_graph
open Grew_rule
(* ==================================================================================================== *)
module Rewrite_history = struct
type t = {
instance: Instance.t;
module_name: string;
......@@ -27,7 +26,6 @@ module Rewrite_history = struct
| { good_nf = [] } -> 0 (* dead branch *)
| { good_nf = l} -> List.fold_left (fun acc t -> acc + (num_sol t)) 0 l
let save_nfs ?main_feat ~dot base_name t =
let rec loop file_name rules t =
match (t.good_nf, t.bad_nf) with
......@@ -47,7 +45,6 @@ module Rewrite_history = struct
[] l
in loop base_name [] t
let save_gr base t =
let rec loop file_name t =
match (t.good_nf, t.bad_nf) with
......@@ -63,11 +60,9 @@ module Rewrite_history = struct
| [one], [] -> loop one
| _ -> Error.run "Not a single rewriting"
in loop t
end
end (* module Rewrite_history *)
(* ==================================================================================================== *)
module Modul = struct
type t = {
name: string;
......@@ -102,8 +97,9 @@ module Modul = struct
loc = ast_module.Ast.mod_loc;
} in
check modul; modul
end
end (* module Modul *)
(* ==================================================================================================== *)
module Sequence = struct
type t = {
name: string;
......@@ -127,8 +123,9 @@ module Sequence = struct
loc = ast_sequence.Ast.seq_loc;
} in
check module_list sequence; sequence
end
end (* module Sequence *)
(* ==================================================================================================== *)
module Grs = struct
type t = {
......@@ -253,4 +250,4 @@ module Grs = struct
(fun modul ->
List.iter (fun filter -> fct modul.Modul.name filter) modul.Modul.filters
) grs.modules
end
end (* module Grs *)
src/grew_html.ml
View file @ c0994a10
......@@ -27,27 +27,30 @@ let html_header ?title buff =
module Html_doc = struct
let string_of_concat_item = function
| Ast.Qfn_item (n,f) -> sprintf "%s.%s" n f
| Ast.Qfn_item (n,fn) -> sprintf "%s.%s" (Ast.c_ident_to_string n) fn
| Ast.String_item s -> sprintf "\"%s\"" s
| Ast.Param_item var -> sprintf "%s" var
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>";
(match u_command with
| Ast.Del_edge_expl (n1,n2,label) -> bprintf buff "del_edge %s -[%s]-> %s" n1 label n2
| Ast.Del_edge_expl (n1,n2,label) ->
bprintf buff "del_edge %s -[%s]-> %s" (Ast.c_ident_to_string n1) label (Ast.c_ident_to_string 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) -> bprintf buff "shift_in %s ==> %s" n1 n2
| Ast.Shift_out (n1,n2) -> bprintf buff "shift_out %s ==> %s" n1 n2
| Ast.Shift_edge (n1,n2) -> bprintf buff "shift %s ==> %s" n1 n2
| 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 n -> bprintf buff "del_node %s" n
| Ast.Update_feat (qfn,item_list) -> bprintf buff "%s = %s" (string_of_qfn qfn) (List_.to_string string_of_concat_item " + " item_list)
| Ast.Del_feat qfn -> bprintf buff "del_feat %s" (string_of_qfn qfn)
| Ast.Add_edge (n1,n2,label) ->
bprintf buff "add_edge %s -[%s]-> %s" (Ast.c_ident_to_string n1) label (Ast.c_ident_to_string n2)
| Ast.Shift_in (n1,n2) ->
bprintf buff "shift_in %s ==> %s" (Ast.c_ident_to_string n1) (Ast.c_ident_to_string n2)
| Ast.Shift_out (n1,n2) -> bprintf buff "shift_out %s ==> %s" (Ast.c_ident_to_string n1) (Ast.c_ident_to_string n2)
| Ast.Shift_edge (n1,n2) -> bprintf buff "shift %s ==> %s" (Ast.c_ident_to_string n1) (Ast.c_ident_to_string n2)
| Ast.Merge_node (n1,n2) -> bprintf buff "merge %s ==> %s" (Ast.c_ident_to_string n1) (Ast.c_ident_to_string n2)
| Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s" (Ast.c_ident_to_string n1) label (Ast.c_ident_to_string n2)
| Ast.Del_node n -> bprintf buff "del_node %s" (Ast.c_ident_to_string n)
| Ast.Update_feat ((n,fn),item_list) ->
bprintf buff "%s.%s = %s" (Ast.c_ident_to_string n) fn (List_.to_string string_of_concat_item " + " item_list)
| Ast.Del_feat (n,fn) ->
bprintf buff "del_feat %s.%s" (Ast.c_ident_to_string n) fn
);
if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
......@@ -83,9 +86,10 @@ 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_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));
| Ast.Feature_eq ((n_l,fn_l), (n_r,fn_r)) -> bprintf buff "%s.%s = %s.%s" n_l fn_l n_r fn_r;
| Ast.Feature_diseq ((n_l,fn_l), (n_r,fn_r)) -> bprintf buff "%s.%s <> %s.%s" n_l fn_l n_r fn_r;
| Ast.Feature_ineq (ineq, (n_l,fn_l), (n_r,fn_r)) -> bprintf buff "%s.%s %s %s.%s" n_l fn_l (Ast.string_of_ineq ineq) n_r fn_r
);
bprintf buff "\n"
let buff_html_pos_pattern buff pos_pattern =
......
src/grew_rule.ml
View file @ c0994a10
......@@ -62,27 +62,22 @@ ELSE
ENDIF
end (* module Instance *)
module Instance_set = Set.Make (Instance)
(* ================================================================================ *)
module Instance_set = Set.Make (Instance)
(* ================================================================================ *)
module Rule = struct
(* the [pid] type is used for pattern identifier *)
type pid = Pid.t
(* the [gid] type is used for graph identifier *)
type gid = Gid.t
(* the rewriting depth is bounded to stop rewriting when the system is not terminating *)
let max_depth = ref 500
type const =
| 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
| Cst_out of Pid.t * P_edge.t
| Cst_in of Pid.t * P_edge.t
| Feature_eq of Pid.t * string * Pid.t * string
| Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match pattern *)
| 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 *)
| Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
| Filter of Pid.t * 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 =
let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
......@@ -171,6 +166,9 @@ module Rule = struct
let get_loc t = t.loc
let is_filter t = t.commands = []
(* ====================================================================== *)
let to_dep t =
let buff = Buffer.create 32 in
bprintf buff "[GRAPH] { scale = 200; }\n";
......@@ -228,19 +226,25 @@ module Rule = struct
bprintf buff "}\n";
Buffer.contents buff
let is_filter t = t.commands = []
(* ====================================================================== *)
let build_commands ?param ?(locals=[||]) pos pos_table ast_commands =
let known_node_ids = Array.to_list pos_table in
let known_c_ident_ids = List.map (fun x -> (x,None)) (Array.to_list pos_table) in
let known_edge_ids = get_edge_ids pos in
let rec loop (kni,kei) = function
let rec loop (kci,kei) = function
| [] -> []
| ast_command :: tail ->
let (command, (new_kni, new_kei)) =
Command.build ?param (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 (command, (new_kci, new_kei)) =
Command.build
?param
(kci,kei)
pos_table
locals
ast_command in
command :: (loop (new_kci,new_kei) tail) in
loop (known_c_ident_ids, known_edge_ids) ast_commands
(* ====================================================================== *)
let parse_vars loc vars =
let rec parse_cmd_vars = function
| [] -> []
......@@ -253,6 +257,7 @@ module Rule = struct
| x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
parse_pat_vars vars
(* ====================================================================== *)
let build ?(locals=[||]) dir rule_ast =
let (param, pat_vars, cmd_vars) =
......@@ -286,10 +291,11 @@ module Rule = struct
param_names = (pat_vars,cmd_vars)
}
(* ====================================================================== *)
type matching = {
n_match: gid Pid_map.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 *)
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
a_match: (Gid.t*Label.t*Gid.t) list; (* anonymous edge mached *)
m_param: Lex_par.t option;
}
......@@ -311,7 +317,7 @@ module Rule = struct
let find cnode ?loc (matching, created_nodes) =
match cnode with