Commit 0f51d2fe authored by bguillaum's avatar bguillaum

Version 0.10.0

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7028 7838e531-6607-4d57-9587-6c381814729c
parent 03e4addc
......@@ -28,7 +28,7 @@ INFO = @INFO@
OCAMLFIND_DIR=`ocamlfind printconf destdir`
VERSION = 0.9.11
VERSION = 0.10.0
cleanup:
rm -rf *.cmo *.cmx *.cmi *.annot *.o *.*~
......
......@@ -73,8 +73,8 @@ ifeq (@DEP2PICT@,no)
ocamlc -c -pp 'camlp4o pa_macro.cmo' $(BYPE_FLAGS) $(FILES_CMO) str.cma -I parser $(PARSER_CMO) libgrew.mli
ocamlc -a -o libgrew.cma $(BYPE_FLAGS) -pp 'camlp4o pa_macro.cmo -DDATA_DIR=\"$(DATA_DIR)\"' -linkall $(FILES_CMO) -I parser $(PARSER_CMO) libgrew.ml
else
ocamlc -c -pp 'camlp4o pa_macro.cmo -DDEP2PICT' $(FILES_CMO) str.cma -I parser $(PARSER_CMO) libgrew.mli
ocamlc -a -o libgrew.cma -pp 'camlp4o pa_macro.cmo -DDATA_DIR=\"$(DATA_DIR)\" -DDEP2PICT' -linkall $(FILES_CMO) -I parser $(PARSER_CMO) libgrew.ml
ocamlc -c -pp 'camlp4o pa_macro.cmo -DDEP2PICT' $(BYPE_FLAGS) $(FILES_CMO) str.cma -I parser $(PARSER_CMO) libgrew.mli
ocamlc -a -o libgrew.cma $(BYPE_FLAGS) -pp 'camlp4o pa_macro.cmo -DDATA_DIR=\"$(DATA_DIR)\" -DDEP2PICT' -linkall $(FILES_CMO) -I parser $(PARSER_CMO) libgrew.ml
endif
libgrew.cmxa : $(FILES_CMX) parser_opt libgrew.mli libgrew.ml
......
......@@ -142,15 +142,13 @@ module Ast = struct
}
end (* module Ast *)
module AST_HTML = struct
let feat_values_tab_to_html = List_.to_string (fun x->x) " | "
let string_of_concat_item = function
| Ast.Qfn_item (n,f) -> sprintf "%s.%s" n f
| Ast.String_item s -> sprintf "\"%s\"" s
| Ast.Param_item var -> sprintf "@%s" var
| Ast.Param_item var -> sprintf "%s" var
let string_of_qfn (node, feat_name) = sprintf "%s.%s" node feat_name
......@@ -165,7 +163,7 @@ module AST_HTML = struct
| 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 \n" n1 label 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)
......
......@@ -17,7 +17,8 @@ module Command = struct
type item =
| Feat of (cnode * string)
| String of string
| Param of int
| Param_in of int
| Param_out of int
(* the command in pattern *)
type p =
......@@ -49,7 +50,7 @@ module Command = struct
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
let build ?cmd_vars (kni, kei) table locals ast_command =
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 id
......@@ -123,12 +124,13 @@ module Command = struct
| 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 cmd_vars with
match param with
| None -> Error.build "Unknown command variable '%s'" var
| Some l ->
match List_.pos var l with
| Some index -> Param index
| 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
......@@ -13,7 +13,8 @@ module Command : sig
type item =
| Feat of (cnode * string)
| String of string
| Param of int
| Param_in of int
| Param_out of int
type p =
| DEL_NODE of cnode
......@@ -44,7 +45,7 @@ module Command : sig
| H_MERGE_NODE of (gid * gid)
val build:
?cmd_vars: string list ->
?param: (string list * string list) ->
(string list * string list) ->
Id.table ->
Label.decl array ->
......
......@@ -56,7 +56,7 @@ module P_feature = struct
(* feature= (feature_name, disjunction of atomic values) *)
type v =
| Equal of string list (* with Equal constr, the list is MUST never be empty *)
| Equal of string list (* with Equal constr, the list MUST never be empty *)
| Different of string list
| Param of int
......@@ -66,6 +66,15 @@ module P_feature = struct
let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
let unif_value v1 v2 =
match (v1, v2) with
| (Equal l1, Equal l2) ->
(match List_.sort_inter l1 l2 with
| [] -> Error.build "Unification failure"
| l -> Equal l)
| (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
| _ -> Error.build "cannot unify heterogeneous pattern features"
let to_string = function
| (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string (fun x->x) "|" atoms)
| (feat_name, Different []) -> sprintf "%s=*" feat_name
......@@ -171,6 +180,8 @@ module P_fs = struct
let to_string t = List_.to_string P_feature.to_string "\\n" t
let to_dep t = List_.to_string P_feature.to_string "#" t
let to_dot t = List_.to_string P_feature.to_string "\\n" t
exception Fail
......@@ -218,4 +229,16 @@ module P_fs = struct
| _ -> false
in loop (fs_p, fs_g)
let unif fs1 fs2 =
let rec loop = function
| [], fs -> fs
| fs, [] -> fs
| ((fn1,v1)::t1, (fn2,v2)::t2) when fn1 < fn2 -> (fn1,v1) :: (loop (t1,(fn2,v2)::t2))
| ((fn1,v1)::t1, (fn2,v2)::t2) when fn1 > fn2 -> (fn2,v2) :: (loop ((fn1,v1)::t1,t2))
(* all remaining case are fn1 = fn2 *)
| ((fn1,v1)::t1, (fn2,v2)::t2) (* when fn1 = fn2 *) -> (fn1,P_feature.unif_value v1 v2) :: (loop (t1,t2))
in loop (fs1, fs2)
end
......@@ -49,6 +49,8 @@ module P_fs: sig
val to_string: t -> string
val to_dep: t -> string
val to_dot: t -> string
exception Fail
......@@ -60,4 +62,6 @@ module P_fs: sig
val match_: ?param:Lex_par.t -> t -> G_fs.t -> Lex_par.t option
val filter: t -> G_fs.t -> bool
val unif: t -> t -> t
end
......@@ -41,17 +41,34 @@ module P_graph = struct
let fs = P_fs.build ast_node.Ast.fs in
(pid, fs)
let build ?pat_vars ?(locals=[||]) full_node_list full_edge_list =
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 (P_node.build ?pat_vars (ast_node, loc) :: tail_nodes, tail_const) in
loop [] full_node_list in
let build ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
(* 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 (P_node.build ?pat_vars (ast_node, loc) :: tail_nodes, tail_const) in *)
(* loop [] full_node_list in *)
let rec insert (ast_node, loc) = function
| [] -> [P_node.build ?pat_vars (ast_node, loc)]
| (n,h)::t when ast_node.Ast.node_id = n ->
(n, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) h) :: t
| h::t -> h :: (insert (ast_node, loc) t) in
let (named_nodes : (Id.name * P_node.t) list) =
let rec loop = function
| [] -> []
| ast_node :: tail ->
let tail_nodes = loop tail in
insert ast_node tail_nodes in
(* let old_node = List.find (fun n -> P_node.get_name) *)
(* if List.mem ast_node.Ast.node_id already_bound *)
(* then (tail_nodes, (ast_node, loc)::tail_const) *)
(* else (P_node.build ?pat_vars (ast_node, loc) :: tail_nodes, tail_const) in *)
loop 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
......@@ -62,7 +79,7 @@ module P_graph = struct
(* the nodes, in the same order *)
let map_without_edges = List_.foldi_left (fun i acc elt -> Pid_map.add i elt acc) Pid_map.empty node_list in
let map =
let (map : t) =
List.fold_left
(fun acc (ast_edge, loc) ->
let i1 = Id.build ~loc ast_edge.Ast.src table in
......@@ -75,7 +92,42 @@ module P_graph = struct
(Loc.to_string loc)
)
) map_without_edges full_edge_list in
(map, table, List.map (build_filter table) constraints)
(map, table, [](* List.map (build_filter table) constraints *))
let to_dep t =
let buff = Buffer.create 32 in
bprintf buff "[GRAPH] { scale = 200; }\n";
bprintf buff "[WORDS] {\n";
Pid_map.iter
(fun id node ->
bprintf buff " N_%d { word=\"%s\"; subword=\"%s\"}\n"
id
(P_node.get_name node)
(P_fs.to_dep (P_node.get_fs node))
) t;
bprintf buff "}\n";
bprintf buff "[EDGES] {\n";
Pid_map.iter
(fun id_src node ->
Massoc.iter
(fun id_tar edge ->
bprintf buff " N_%d -> N_%d { label=\"%s\"}\n"
id_src id_tar
(P_edge.to_string edge)
)
(P_node.get_next node)
) t;
bprintf buff "}\n";
Buffer.contents buff
(* a type for extension of graph: a former graph exists:
in grew the former is a positive pattern and an extension is a "without" *)
......
......@@ -24,6 +24,8 @@ module P_graph: sig
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
val to_dep: t -> string
val build:
?pat_vars: string list ->
?locals: Label.decl array ->
......
......@@ -210,7 +210,6 @@ module Sequence = struct
end
module Grs = struct
type sequence = string * string list (* (name of the seq, list of modules) *)
type t = {
labels: Label.t list; (* the list of global edge labels *)
......@@ -318,6 +317,14 @@ module Grs = struct
)
in loop instance modules_to_apply
let rule_iter fct grs =
List.iter
(fun modul ->
List.iter
(fun rule ->
fct modul.Modul.name rule
) modul.Modul.rules
) grs.modules
end
module Gr_stat = struct
......
......@@ -38,6 +38,8 @@ module Grs: sig
(* only externeal strucutre is returned, each edge contains a "dummy" big_step *)
val build_rew_display: t -> string -> Instance.t -> Grew_types.rew_display
val rule_iter: (string -> Rule.t -> unit) -> t -> unit
end
......
open Printf
open Dep2pict
open Grew_ast
module Html = struct
......@@ -53,8 +56,11 @@ let module_page_text previous next m ast = "
"</body>
</html>"
let rule_page_text previous next rule m ast file = "
<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
let rule_page_text previous next rule m ast file =
let dep_pattern_file = sprintf "%s_%s-patt.png" m.Ast.module_id rule.Ast.rule_id in
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
<html>
<head>
<link rel=\"stylesheet\" href=\"style.css\" type=\"text/css\">
......@@ -70,9 +76,14 @@ let rule_page_text previous next rule m ast file = "
"
</pre></code><br/><h6>Code</h6><pre>"^
<br/><h6>Code</h6><pre>"^
(AST_HTML.to_html_rules [rule])^
"</pre><br/>
<br/><h6>Pattern</h6><pre>"^
("<IMG src=\""^dep_pattern_file^"\">")^
"</pre><br/>
</body>
</html>"
......
......@@ -74,18 +74,24 @@ end
(* ================================================================================ *)
module P_node = struct
type t = {
name: Id.name;
fs: P_fs.t;
next: P_edge.t Massoc.t;
}
let get_name t = t.name
let get_fs t = t.fs
let get_next t = t.next
let empty = { fs = P_fs.empty; next = Massoc.empty }
let unif_fs fs t = { t with fs = P_fs.unif fs t.fs }
let empty = { fs = P_fs.empty; next = Massoc.empty; name = "" }
let build ?pat_vars (ast_node, loc) =
(ast_node.Ast.node_id,
{ fs = P_fs.build ?pat_vars ast_node.Ast.fs;
{
name = ast_node.Ast.node_id;
fs = P_fs.build ?pat_vars ast_node.Ast.fs;
next = Massoc.empty;
} )
......
......@@ -43,9 +43,13 @@ module P_node: sig
val empty: t
val get_name: t -> Id.name
val get_fs: t -> P_fs.t
val get_next: t -> P_edge.t Massoc.t
(** [unif_fs fs t] replaces the feature structure of the node by node.fs unif fs *)
val unif_fs: P_fs.t -> t -> t
val build: ?pat_vars: string list -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> int -> t -> t option
......
......@@ -62,9 +62,13 @@ 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 = int
(* the rewriting depth is bounded to stop rewriting when the system is not terminating *)
let max_depth = ref 500
type const =
......@@ -80,11 +84,11 @@ module Rule = struct
| (Ast.No_in node_name, loc) -> No_in (Id.build ~loc node_name table, P_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: P_graph.t;
constraints: const list;
}
type pattern = {
graph: P_graph.t;
constraints: const list;
}
let build_pos_pattern ?pat_vars ?(locals=[||]) pattern_ast =
let (graph,table,filter_nodes) = P_graph.build ?pat_vars ~locals pattern_ast.Ast.pat_nodes pattern_ast.Ast.pat_edges in
......@@ -98,6 +102,8 @@ module Rule = struct
table
)
(* the neg part *)
let build_neg_constraint ?locals pos_table neg_table const =
let id_build loc string_id =
......@@ -134,24 +140,26 @@ module Rule = struct
pos: pattern;
neg: pattern list;
commands: Command.t list;
loc: Loc.t;
param: Lex_par.t option;
loc: Loc.t;
}
let get_name t = t.name
let get_loc t = t.loc
let to_dep t = P_graph.to_dep t.pos.graph
let is_filter t = t.commands = []
let build_commands ?cmd_vars ?(locals=[||]) pos pos_table ast_commands =
let build_commands ?param ?(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 ?cmd_vars (kni,kei) pos_table locals ast_command in
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
......@@ -185,7 +193,7 @@ module Rule = struct
name = rule_ast.Ast.rule_id;
pos = pos;
neg = List.map (fun p -> build_neg_pattern ~locals pos_table p) rule_ast.Ast.neg_patterns;
commands = build_commands ~cmd_vars ~locals pos pos_table rule_ast.Ast.commands;
commands = build_commands ~param:(pat_vars,cmd_vars) ~locals pos pos_table rule_ast.Ast.commands;
loc = rule_ast.Ast.rule_loc;
param = param;
};
......@@ -471,10 +479,14 @@ module Rule = struct
(function
| Command.Feat (cnode, feat_name) -> G_graph.Feat (node_find cnode, feat_name)
| Command.String s -> G_graph.String s
| Command.Param index ->
match matching.m_param with
| Command.Param_out index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> G_graph.String (Lex_par.get_command_value index param))
| Command.Param_in index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> G_graph.String (Lex_par.get_command_value index param)
| Some param -> G_graph.String (Lex_par.get_param_value index param))
) item_list in
let (new_graph, new_feature_value) =
......@@ -745,4 +757,4 @@ module Rule = struct
let (good_set, bad_set) = Instance_set.partition (filter_instance filters) output_set in
(good_set, bad_set)
end
end (* module Rule *)
......@@ -39,11 +39,13 @@ module Rule : sig
val get_name: t -> string
(** [get_loc t] returns the file location of th*)
(** [get_loc t] returns the file location of the rule [t]. *)
val get_loc: t -> Loc.t
val is_filter: t -> bool
val to_dep: t -> string
(** [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
......
......@@ -7,7 +7,6 @@ module StringMap = Map.Make (String)
module IntSet = Set.Make (struct type t = int let compare = Pervasives.compare end)
module IntMap = Map.Make (struct type t = int let compare = Pervasives.compare end)
(* ================================================================================ *)
module Loc = struct
type t = string * int
......@@ -23,7 +22,6 @@ module Loc = struct
| Some x -> to_string x
end (* module Loc *)
(* ================================================================================ *)
module File = struct
let write data name =
......@@ -295,6 +293,15 @@ module List_ = struct
| x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
loop (l1,l2)
let sort_union l1 l2 =
let rec loop = function
| [], l | l, [] -> l
| x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
| x1::t1, x2::t2 when x1 > x2 -> x2 :: loop (x1::t1, t2)
| x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
loop (l1,l2)
exception Not_disjoint
let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
let rec loop = function
......@@ -544,7 +551,7 @@ module Conll = struct
List.map parse lines
end
(* This module defiens a type for lexical parameter (i.e. one line in a lexical file) *)
(* This module defines a type for lexical parameter (i.e. one line in a lexical file) *)
module Lex_par = struct
type item = string list * string list (* first list: pattern parameters $id , second list command parameters @id *)
......@@ -603,14 +610,23 @@ module Lex_par = struct
with
| [] -> None
| t -> Some t
let get_param_value index = function
| [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
| (params,_)::_ -> List.nth params index
let get_command_value index = function
| [(_,one)] -> List.nth one index
| [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
| (_,[sing])::tail when index=0 ->
Printf.sprintf "%s/%s"
sing
(List_.to_string (function (_,[s]) -> s | _ -> Error.bug "[Lex_par.get_command_value] inconsistent param") "/" tail)
(List_.to_string
(function
| (_,[s]) -> s
| _ -> Error.bug "[Lex_par.get_command_value] inconsistent param"
) "/" tail
)
| l -> Error.run "Lexical parameter are not functionnal"
end
......
......@@ -93,6 +93,7 @@ module List_: sig
val sort_is_empty_inter: 'a list -> 'a list -> bool
val sort_inter: 'a list -> 'a list -> 'a list
val sort_union: 'a list -> 'a list -> 'a list
val sort_disjoint_union: ?compare:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
val sort_include: 'a list -> 'a list -> bool
val sort_included_diff: 'a list -> 'a list -> 'a list
......@@ -209,6 +210,9 @@ module Lex_par: sig
*)
val filter: int -> string -> t -> t option
(** [get_param_value index t] returns the [index]^th param_var. *)
val get_param_value: int -> t -> string
(** [get_command_value index t] supposes that [t] contains iny one element.
It returns the [index]^th command_var. *)
val get_command_value: int -> t -> string
......
......@@ -2,6 +2,7 @@ include Grew_types
open Printf
open Log
open Dep2pict
open Grew_utils
open Grew_graph
......@@ -36,10 +37,19 @@ let load_grs ?doc_output_dir file =
else
try
let grs_ast = Grew_parser.grs_of_file file in
let grs = Grs.build grs_ast in
(match doc_output_dir with
| None -> ()
| Some dir -> Html.proceed dir grs_ast);
Grs.build grs_ast
| Some dir ->
Html.proceed dir grs_ast;
Grs.rule_iter
(fun modul_name rule ->
let dep_code = Rule.to_dep rule in
let dep_svg_file = sprintf "%s/%s_%s-patt.png" dir modul_name (Rule.get_name rule) in
ignore (Dep2pict.fromDepStringToPng dep_code dep_svg_file)
) grs
);
grs
with
| Grew_parser.Parse_error (msg,Some (sub_file,l)) ->
raise (Parsing_err (sprintf "[file:%s, line:%d] %s" sub_file l msg))
......
......@@ -497,6 +497,7 @@ concat_item:
| s = IDENT { Ast.String_item s }
| s = STRING { Ast.String_item s }
| p = CMD { Ast.Param_item p }
| p = PAT { Ast.Param_item p }
/*=============================================================================================*/
/* */
......
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