Commit d92aaf2c authored by bguillaum's avatar bguillaum
Browse files

ongoing strategies

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@9088 7838e531-6607-4d57-9587-6c381814729c
parent fc569a06
......@@ -313,49 +313,7 @@ module Ast = struct
mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
}
type old_sequence = {
seq_name:string;
seq_mod:string list;
seq_doc:string list;
seq_loc:Loc.t;
}
type new_sequence =
| Ref of string
| List of new_sequence list
| Plus of new_sequence list
| Star of new_sequence
| Diamond of new_sequence
let rec new_sequence_to_string = function
| Ref m -> m
| List l -> "[" ^ (String.concat "; " (List.map new_sequence_to_string l)) ^ "]"
| Plus l -> "[" ^ (String.concat "+" (List.map new_sequence_to_string l)) ^ "]"
| Star s -> "[" ^ (new_sequence_to_string s) ^"]" ^ "*"
| Diamond s -> "◇" ^ "[" ^(new_sequence_to_string s)^"]"
let rec flatten = function
| Ref m -> Ref m
| Star s -> Star (flatten s)
| Diamond s -> Diamond (flatten s)
| List l ->
let fl = List.map flatten l in
let rec loop = function
| [] -> []
| (List l) :: tail -> l @ (loop tail)
| x :: tail -> x :: (loop tail)
in List (loop fl)
| Plus l ->
let fl = List.map flatten l in
let rec loop = function
| [] -> []
| (Plus l) :: tail -> l @ (loop tail)
| x :: tail -> x :: (loop tail)
in Plus (loop fl)
type sequence =
| Old of old_sequence
| New of ((string * Loc.t) * new_sequence)
(** a GRS: graph rewriting system *)
type module_or_include =
......@@ -367,20 +325,18 @@ module Ast = struct
label_domain: (string * string list) list;
}
let empty_domain = { feature_domain=[]; label_domain=[] }
type domain_wi = Dom of domain | Dom_file of string
type grs_wi = {
domain_wi: domain_wi option;
modules_wi: module_or_include list;
sequences_wi: sequence list;
strategies_wi: Strategy.t list;
}
type grs = {
domain: domain option;
modules: modul list;
sequences: sequence list;
strategies: Strategy.t list;
}
type gr = {
......@@ -389,6 +345,6 @@ module Ast = struct
edges: edge list;
}
let empty_grs = { domain = None; modules = []; sequences= [] }
let empty_grs = { domain = None; modules = []; strategies= [] }
end (* module Ast *)
......@@ -174,26 +174,10 @@ module Ast : sig
mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
}
type old_sequence = {
seq_name:string;
seq_mod:string list;
seq_doc:string list;
seq_loc:Loc.t;
}
type new_sequence =
| Ref of string
| List of new_sequence list
| Plus of new_sequence list
| Star of new_sequence
| Diamond of new_sequence
val new_sequence_to_string : new_sequence -> string
val flatten : new_sequence -> new_sequence
type sequence =
| Old of old_sequence
| New of ((string * Loc.t) * new_sequence)
type module_or_include =
| Modul of modul
......@@ -209,14 +193,14 @@ module Ast : sig
type grs_wi = {
domain_wi: domain_wi option;
modules_wi: module_or_include list;
sequences_wi: sequence list;
strategies_wi: Strategy.t list;
}
(* a GRS: graph rewriting system *)
type grs = {
domain: domain option;
modules: modul list;
sequences: sequence list;
strategies: Strategy.t list;
}
type gr = {
......
......@@ -158,9 +158,6 @@ module G_fs = struct
(* list are supposed to be strictly ordered wrt compare *)
type t = G_feature.t list
(* ---------------------------------------------------------------------- *)
let to_raw t = List.map (fun (name, value) -> (name, string_of_value value)) t
(* ---------------------------------------------------------------------- *)
let empty = []
......
......@@ -38,7 +38,6 @@ module G_fs: sig
val to_dot: ?decorated_feat:(string * string list) -> ?main_feat: string -> t -> string
val to_word: ?main_feat: string -> t -> string
val to_dep: ?decorated_feat:(string * string list) -> ?position:float -> ?main_feat: string -> ?filter: string list -> t -> string
val to_raw: t -> (string * string) list
val to_conll: ?exclude: string list -> t -> string
(** [get_annot_info fs] searches for a feature with name starting with "__".
......
......@@ -785,24 +785,6 @@ module G_graph = struct
| _::t -> loop (n+1) t
in loop 0
let to_raw ?domain graph =
let nodes = Gid_map.fold (fun id elt acc -> (id,elt)::acc) graph.map [] in
let snodes = List.sort (fun (_,n1) (_,n2) -> G_node.position_comp n1 n2) nodes in
let raw_nodes = List.map (fun (gid,node) -> (gid, G_fs.to_raw (G_node.get_fs node))) snodes in
let get_num gid = list_num (fun (x,_) -> x=gid) raw_nodes in
let edge_list = ref [] in
Gid_map.iter
(fun src_gid node ->
Massoc_gid.iter
(fun tar_gid edge ->
edge_list := (get_num src_gid, G_edge.to_string ?domain edge, get_num tar_gid) :: !edge_list
)
(G_node.get_next node)
)
graph.map;
(graph.meta, List.map snd raw_nodes, !edge_list)
(* -------------------------------------------------------------------------------- *)
let to_conll_string ?domain graph =
let nodes = Gid_map.fold
......
......@@ -168,9 +168,4 @@ module G_graph: sig
val to_sentence: ?main_feat:string -> t -> string
val to_dep: ?domain:Domain.t -> ?filter : string list -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_conll_string: ?domain:Domain.t -> t -> string
val to_raw: ?domain:Domain.t -> t ->
string list *
(string * string) list list *
(int * string * int) list
end (* module G_graph *)
\ No newline at end of file
......@@ -184,45 +184,13 @@ module Modul = struct
check modul; modul
end (* module Modul *)
(* ================================================================================ *)
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 =
match ast_sequence with
| Ast.New ((n,_),s) ->
printf "----%s----> %s\n%!" n (Ast.new_sequence_to_string s);
printf "====%s====> %s\n%!" n (Ast.new_sequence_to_string (Ast.flatten s));
{name=n; def=[]; loc=Loc.file "No_file_given"; }
| Ast.Old old_seq ->
let sequence =
{
name = old_seq.Ast.seq_name;
def = old_seq.Ast.seq_mod;
loc = old_seq.Ast.seq_loc;
} in
check module_list sequence; sequence
end (* module Sequence *)
(* ================================================================================ *)
module Grs = struct
type t = {
domain: Domain.t option;
modules: Modul.t list; (* the ordered list of modules used from rewriting *)
sequences: Sequence.t list;
strategies: Strategy.t list;
filename: string;
ast: Ast.grs;
}
......@@ -230,10 +198,12 @@ module Grs = struct
let get_modules t = t.modules
let get_ast t = t.ast
let get_filename t = t.filename
let get_domain t = t.domain
let sequence_names t = List.map (fun s -> s.Sequence.name) t.sequences
let empty = {domain=None; modules=[]; sequences=[]; ast=Ast.empty_grs; filename=""; }
let sequence_names t = List.map (fun s -> s.Strategy.name) t.strategies
let empty = {domain=None; modules=[]; strategies=[]; ast=Ast.empty_grs; filename=""; }
let check t =
(* check for duplicate modules *)
......@@ -244,13 +214,13 @@ module Grs = struct
| m::tail -> loop (m.Modul.name :: already_defined) tail in
loop [] t.modules;
(* check for duplicate sequences *)
(* check for duplicate strategies *)
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
| s::_ when List.mem s.Strategy.name already_defined ->
Error.build ~loc:s.Strategy.loc "Sequence '%s' is defined twice" s.Strategy.name
| s::tail -> loop (s.Strategy.name :: already_defined) tail in
loop [] t.strategies
let domain_build ast_domain =
Domain.build
......@@ -261,30 +231,16 @@ module Grs = struct
let ast = Loader.grs filename in
let domain = match ast.Ast.domain with None -> None | Some ast_dom -> Some (domain_build ast_dom) in
let modules = List.map (Modul.build ?domain) ast.Ast.modules in
let grs = {domain; sequences = List.map (Sequence.build modules) ast.Ast.sequences; modules; ast; filename} in
let grs = {domain; strategies = ast.Ast.strategies; modules; ast; filename} in
check grs;
grs
(* compute the list of modules to apply for a requested sentence *)
let modules_of_sequence grs sequence =
try
let seq = List.find (fun s -> s.Sequence.name = sequence) grs.sequences in
List.map (fun name -> List.find (fun m -> m.Modul.name=name) grs.modules) seq.Sequence.def
with Not_found ->
try
let modul = List.find (fun m -> m.Modul.name=sequence) grs.modules in
Log.fwarning "\"%s\" is a module but not a senquence, only this module is used" sequence; [modul]
with Not_found ->
match grs.sequences with
| head::_ ->
Log.fwarning "No sequence and no module named \"%s\", the first sequence \"%s\" is used" sequence head.Sequence.name;
List.map (fun name -> List.find (fun m -> m.Modul.name=name) grs.modules) head.Sequence.def
| _ -> Error.run "No sequence defined and no module named \"%s\", cannot go on" sequence
let rewrite grs sequence graph =
let instance = Instance.from_graph graph in
Timeout.start ();
let modules_to_apply = modules_of_sequence grs sequence in
let modules_to_apply = [] (* modules_of_sequence grs sequence *) in
let rec loop instance module_list =
match module_list with
......@@ -309,10 +265,32 @@ module Grs = struct
} in
loop instance modules_to_apply
let build_rew_display grs sequence graph =
(* construction of the rew_display *)
let rec diamond = function
| Libgrew_types.Node (_, _, []) -> Log.bug "Empty node"; exit 12
| Libgrew_types.Node (graph, name, (bs,rd)::_) -> Libgrew_types.Node (graph, "◇" ^ name, [(bs, diamond rd)])
| x -> x
let rec clean = function
| Libgrew_types.Empty -> Libgrew_types.Empty
| Libgrew_types.Leaf graph -> Libgrew_types.Leaf graph
| Libgrew_types.Local_normal_form (graph, name, Libgrew_types.Empty) -> Libgrew_types.Empty
| Libgrew_types.Local_normal_form (graph, name, rd) -> Libgrew_types.Local_normal_form (graph, name, clean rd)
| Libgrew_types.Node (graph, name, bs_rd_list) ->
match
List.fold_left (fun acc (bs,rd) ->
match clean rd with
| Libgrew_types.Empty -> acc
| crd -> (bs, crd) :: acc
) [] bs_rd_list
with
| [] -> Libgrew_types.Empty
| new_bs_rd_list -> Libgrew_types.Node (graph, name, new_bs_rd_list)
let build_rew_display grs strategy graph =
let instance = Instance.from_graph graph in
let modules_to_apply = modules_of_sequence grs sequence in
(* =============
let rec loop instance module_list =
match module_list with
| [] -> Libgrew_types.Leaf instance.Instance.graph
......@@ -338,11 +316,101 @@ module Grs = struct
List.map
(fun inst ->
match inst.Instance.big_step with
======= *)
let indent = ref 10 in
let strat = List.find (fun s -> s.Strategy.name = strategy) grs.strategies in
let rec apply_leaf strat = function
| Libgrew_types.Empty -> Libgrew_types.Empty
| Libgrew_types.Leaf graph -> loop (Instance.from_graph graph) strat
| Libgrew_types.Local_normal_form (graph, name, rd) -> Libgrew_types.Local_normal_form (graph, name, apply_leaf strat rd)
| Libgrew_types.Node (graph, name, bs_rd_list) -> Libgrew_types.Node (graph, name, List.map (fun (bs,rd) -> (bs, apply_leaf strat rd)) bs_rd_list)
and loop (instance : Instance.t) def =
printf "%s===> loop def=%s\n%!"
(String.make (2 * !indent) ' ')
(Strategy.to_string def);
incr indent;
match def with
(* ========> reference to a module or to another strategy <========= *)
| Strategy.Ref name ->
begin
try
let strat = List.find (fun s -> s.Strategy.name = name) grs.strategies in
loop instance strat.Strategy.def
with Not_found ->
let modul =
try List.find (fun m -> m.Modul.name=name) grs.modules
with Not_found -> Log.fcritical "No [strategy or] module named '%s'" name in
begin
printf "%s one_step (module=%s)...%!" (String.make (2 * !indent) ' ') modul.Modul.name;
let domain = get_domain grs in
match Rule.one_step ?domain modul.Modul.name instance modul.Modul.rules with
| [] -> printf "0\n%!"; let res = Libgrew_types.Empty in decr indent; res
| instance_list -> printf "%d\n%!" (List.length instance_list);
Libgrew_types.Node
(instance.Instance.graph,
name,
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
| Some bs -> let res = (bs, Libgrew_types.Leaf inst.Instance.graph) in decr indent; res
) instance_list
)
end
end
(* ========> Strat defined as a sequence of sub-strategies <========= *)
| Strategy.Seq [] -> Log.bug "[Grs.build_rew_display] Empty sequence!"; exit 2
| Strategy.Seq [one] -> let res = loop instance one in decr indent; res
| Strategy.Seq (head_strat :: tail_strat) ->
let one_step = loop instance head_strat in decr indent;
apply_leaf (Strategy.Seq tail_strat) one_step
| Strategy.Diamond strat -> diamond (loop instance strat)
(* ========> Strat defined as a sequence of sub-strategies <========= *)
| Strategy.Plus [] -> Log.bug "[Grs.build_rew_display] Empty union!"; exit 2
| Strategy.Plus strat_list ->
let rd_list = List.map (fun strat -> loop instance strat) strat_list in
let (opt_lnf, opt_node_info) =
List.fold_left (fun (acc_lnf, acc_node) rd ->
match (rd, acc_lnf, acc_node) with
| (Libgrew_types.Empty, acc_lnf, acc_node) -> (acc_lnf, acc_node)
| (Libgrew_types.Leaf graph, None ,_) -> (Some (graph,"0"), acc_node)
| (Libgrew_types.Leaf _,Some (graph,names) ,_) -> (Some (graph,"0+"^names), acc_node)
| (Libgrew_types.Local_normal_form (graph,name,_), None, _) -> (Some (graph,name), acc_node)
| (Libgrew_types.Local_normal_form (_,name,_), Some (graph,names), _) -> (Some (graph,name^"+"^names), acc_node)
| (Libgrew_types.Node (graph,name,bs_rd_list), _, None) -> (acc_lnf, Some (graph,name,bs_rd_list))
| (Libgrew_types.Node (_,name,bs_rd_list), _, Some (graph,acc_names,acc_bs_rd_list)) ->
(acc_lnf, Some (graph, name^"+"^acc_names,bs_rd_list @ acc_bs_rd_list))
) (None,None) rd_list in
begin
match (opt_lnf, opt_node_info) with
| (None, None) -> Libgrew_types.Empty
| (Some (graph,lnf_name), None) -> Libgrew_types.Local_normal_form (graph, lnf_name, Libgrew_types.Leaf graph)
| (None, Some (a,b,c)) -> Libgrew_types.Node (a,b,c)
| (Some (_,lnf_name), Some (graph,acc_name,acc_bs_rd_list)) ->
let bs = {Libgrew_types.first={Libgrew_types.rule_name="dummy";up=G_deco.empty;down=G_deco.empty}; small_step=[]} in
Libgrew_types.Node (graph,acc_name,(bs, Libgrew_types.Leaf graph) :: acc_bs_rd_list)
end
| Strategy.Star strat ->
begin
match clean (loop instance strat) with
| Libgrew_types.Empty -> Libgrew_types.Leaf instance.Instance.graph
| Libgrew_types.Local_normal_form _ -> Log.bug "dont know if 'Local_normal_form' in star should happen or not ???"; exit 1
| rd -> apply_leaf (Strategy.Star strat) rd
end
in
loop instance (strat.Strategy.def)
let rule_iter fct grs =
List.iter
......
......@@ -106,5 +106,5 @@ module Grs: sig
val rule_iter: (string -> Rule.t -> unit) -> t -> unit
val filter_iter: (string -> Rule.t -> unit) -> t -> unit
val modules_of_sequence: t -> string -> Modul.t list
(* val modules_of_sequence: t -> string -> Modul.t list*)
end (* module Grs *)
......@@ -323,17 +323,14 @@ module Html_doc = struct
wnl " <div class=\"navbar\">&nbsp;<a href=\"index.html\">Up</a></div>";
wnl " <center><h1>List of sequences</h1></center>";
List.iter
(function
| Ast.New _ -> failwith "Wait..."
| Ast.Old seq ->
wnl "<h6>%s</h6>" seq.Ast.seq_name;
List.iter (fun l -> wnl "<p>%s</p>" (doc_to_html l)) seq.Ast.seq_doc;
(fun ast_seq ->
wnl "<h6>%s</h6>" ast_seq.Strategy.name;
List.iter (fun l -> wnl "<p>%s</p>" (doc_to_html l)) ast_seq.Strategy.doc;
wnl "<div class=\"code\">";
wnl "%s" (String.concat " ⇨ " (List.map (fun x -> sprintf "<a href=\"%s.html\">%s</a>" x x) seq.Ast.seq_mod));
wnl "%s" (Strategy.to_string ast_seq.Strategy.def);
wnl "</div>";
) ast.Ast.sequences;
) ast.Ast.strategies;
wnl " </body>";
wnl "</html>";
Buffer.contents buff
......@@ -824,7 +821,7 @@ module Corpus_stat = struct
let empty ~grs ~seq =
(* let modules = try List.assoc seq grs.Grs.sequences with Not_found -> [seq] in *)
let modules = Grs.modules_of_sequence grs seq in
let modules = [] (* Grs.modules_of_sequence grs seq *) in
let map = List.fold_left
(fun acc modul ->
if List.exists (fun m -> modul.Modul.name = m.Modul.name) modules
......
......@@ -86,7 +86,7 @@ module Loader = struct
{
Ast.domain = domain;
Ast.modules = flatten_modules main_file grs_wi.Ast.modules_wi;
Ast.sequences = grs_wi.Ast.sequences_wi;
Ast.strategies = grs_wi.Ast.strategies_wi;
}
(* ------------------------------------------------------------------------------------------*)
......
......@@ -224,14 +224,14 @@ grs_wi:
{
{ Ast.domain_wi=(match d with Some dom -> Some (Ast.Dom dom) | None -> None);
modules_wi=m;
sequences_wi=match s with Some seq -> seq | None -> [];
strategies_wi=match s with Some seq -> seq | None -> [];
}
}
| DOMAIN file=STRING m=module_or_include_list s=option(sequences) EOF
{
{ Ast.domain_wi= Some (Ast.Dom_file file);
modules_wi=m;
sequences_wi=match s with Some seq -> seq | None -> [];
strategies_wi=match s with Some seq -> seq | None -> [];
}
}
......@@ -460,7 +460,6 @@ pat_edge_or_const:
| STAR labels=delimited(LTR_EDGE_LEFT,separated_nonempty_list(PIPE,pattern_label_ident),LTR_EDGE_RIGHT) n2_loc=simple_id_with_loc
{ let (n2,loc) = n2_loc in Pat_const (Ast.Cst_in (n2,Ast.Pos_list labels), loc) }
(* "A -[^X|Y]-> B" *)
| n1_loc=simple_id_with_loc labels=delimited(LTR_EDGE_LEFT_NEG,separated_nonempty_list(PIPE,pattern_label_ident),LTR_EDGE_RIGHT) n2=simple_id
{ let (n1,loc) = n1_loc in Pat_edge ({Ast.edge_id = None; src=n1; edge_label_cst=Ast.Neg_list labels; tar=n2}, loc) }
......@@ -693,26 +692,35 @@ sequence:
seq_mod = mod_names;*/
| doc = option(COMMENT) id_loc=simple_id_with_loc mod_names=delimited(LACC,separated_list_final_opt(SEMIC,simple_id),RACC)
{
Ast.Old { Ast.seq_name = fst id_loc;
seq_mod = mod_names ;
seq_doc = begin match doc with Some d -> d | None -> [] end;
seq_loc = snd id_loc;
{ let (name,loc) = id_loc in
{
Strategy.name;
def = Strategy.Seq (List.map (fun m -> Strategy.Ref m) mod_names);
doc = begin match doc with Some d -> d | None -> [] end;
loc;
}
}
| doc = option(COMMENT) id_loc=simple_id_with_loc EQUAL def=op_seq
{ let (name,loc) = id_loc in
{
Strategy.name;
def;
doc = begin match doc with Some d -> d | None -> [] end;
loc;
}
}
| doc = option(COMMENT) id_loc=simple_id_with_loc EQUAL s=op_seq { Ast.New (id_loc, s) }
op_seq:
| m=simple_id { Ast.Ref m }
| m=simple_id { Strategy.Ref m }
| LPAREN s=op_seq RPAREN { s }
| s=op_seq STAR { Ast.Star (s) }
| s1=op_seq PLUS s2=op_seq { Ast.Plus [s1; s2] }
| s1=op_seq SEMIC s2=op_seq { Ast.List [s1; s2] }
| DISEQUAL s=op_seq { Ast.Diamond s }
| s=op_seq STAR { Strategy.Star (s) }
| s1=op_seq PLUS s2=op_seq { Strategy.Plus [s1; s2] }
| s1=op_seq SEMIC s2=op_seq { Strategy.Seq [s1; s2] }
| DISEQUAL s=op_seq { Strategy.Diamond s }
/*=============================================================================================*/
/* ISOLATED PATTERN (grep mode) */
/* ISOLATED PATTERN (grep mode) */
/*=============================================================================================*/
pattern:
| p=pos_item n=list(neg_item) EOF { Ast.complete_pattern {Ast.pat_pos=p; pat_negs=n} }
......
......@@ -1104,6 +1104,7 @@ module Rule = struct
)
to_do_set (Instance_set.empty,nf_set) in
loop new_to_do_set new_nf_set in
let nfs = loop (Instance_set.singleton instance) Instance_set.empty in
let reduced_nfs = filter_equal_nfs nfs in
......
......@@ -96,6 +96,8 @@ module Rule : sig
Instance.t ->
Instance_set.t * Instance_set.t
val one_step: ?domain: Domain.t -> string -> Instance.t -> t list -> Instance.t list
(** the type matching encodes the graph morphism from a pattern to a graph *)
(* NB: it was made public for the grep mode *)
type matching
......
......@@ -443,3 +443,46 @@ module Concat_item = struct
| String of string
end (* module Concat_item *)
(* ================================================================================ *)
module Strategy = struct
type def =
| Ref of string
| Seq of def list (* /!\ The list must not be empty *)
| Plus of def list (* /!\ The list must not be empty *)
| Star of def
| Diamond of def