Commit 89c0c3b5 authored by bguillaum's avatar bguillaum

add simple_rewrite function for applying strategies

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@9143 7838e531-6607-4d57-9587-6c381814729c
parent 01f7b589
......@@ -271,6 +271,111 @@ module Grs = struct
loop (Instance.from_graph graph) (strategy.Strategy.def)
(* [new_style grs module_list] return an equivalent strategy expressed with Seq, Diamond and Star *)
let new_style grs module_list =
Strategy.Seq
(List.map
(fun module_name ->
let modul =
try List.find (fun m -> m.Modul.name=module_name) grs.modules
with Not_found -> Log.fcritical "No module named '%s'" module_name in
if modul.Modul.confluent
then Strategy.Diamond (Strategy.Star (Strategy.Ref module_name))
else Strategy.Star (Strategy.Ref module_name)
) module_list
)
(* [one_rewrite grs strat inst] tries to rewrite deterministically [inst] with [strat] defined in [grs] *)
let one_rewrite grs strat inst =
let rec loop inst = function
(* name can refer to another strategy def or to a module *)
| Strategy.Ref name ->
begin
try
let sub_strat = List.find (fun s -> s.Strategy.name = name) grs.strategies in
loop inst sub_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 module or strategy named '%s'" name in
Rule.conf_one_step ?domain: grs.domain name inst modul.Modul.rules
end
(* Union of strategies *)
| Strategy.Plus [] -> None (* the list can be empty in a recursive call! *)
| Strategy.Plus (head::tail) ->
begin
match loop inst head with
| Some new_inst -> Some new_inst
| None -> loop inst (Strategy.Plus tail)
end
(* Sequence of strategies *)
| Strategy.Seq [] -> Log.fcritical "Empty sequence in strategy definition"
| Strategy.Seq [one] -> loop inst one
| Strategy.Seq (head::tail) ->
begin
match loop inst head with
| Some new_inst -> loop new_inst (Strategy.Seq tail)
| None -> None
end
(* Interation of a strategy *)
| Strategy.Star sub_strat ->
begin
match loop inst sub_strat with
| None -> Some inst
| Some new_inst -> loop new_inst (Strategy.Star sub_strat)
end
(* Diamond *)
| Strategy.Diamond sub_strat -> loop inst sub_strat
(* Old style seq definition *)
| Strategy.Sequence module_list -> loop inst (new_style grs module_list) in
loop inst strat
let simple_rewrite grs strat_desc graph =
let rec loop inst = function
(* name can refer to another strategy def or to a module *)
| Strategy.Ref name ->
begin
try
let sub_strat = List.find (fun s -> s.Strategy.name = name) grs.strategies in
loop inst sub_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 module or strategy named '%s'" name in
Rule.one_step ?domain: grs.domain name inst modul.Modul.rules
end
(* Union of strategies *)
| Strategy.Plus strat_list -> List_.flat_map (loop inst) strat_list
(* Sequence of strategies *)
| Strategy.Seq [] -> Log.fcritical "Empty sequence in strategy definition"
| Strategy.Seq [one] -> loop inst one
| Strategy.Seq (head::tail) ->
let after_first_mod = loop inst head in
List_.flat_map (fun new_inst -> loop new_inst (Strategy.Seq tail)) after_first_mod
(* Interation of a strategy *)
| Strategy.Star sub_strat ->
begin
match loop inst sub_strat with
| [] -> [inst]
| l -> List_.flat_map (fun new_inst -> loop new_inst (Strategy.Star sub_strat)) l
end
(* Diamond *)
| Strategy.Diamond sub_strat ->
begin
match one_rewrite grs sub_strat inst with
| Some new_inst -> [new_inst]
| None -> []
end
(* Old style seq definition *)
| Strategy.Sequence module_list -> loop inst (new_style grs module_list) in
List.map
(fun inst -> inst.Instance.graph)
(loop (Instance.from_graph graph) (Parser.strategy strat_desc))
(* ---------------------------------------------------------------------------------------------------- *)
(* construction of the rew_display *)
......
......@@ -100,6 +100,9 @@ module Grs: sig
val rewrite: t -> string -> G_graph.t -> Rewrite_history.t
val simple_rewrite: t -> string -> G_graph.t -> G_graph.t list
(* only external structure is returned, each edge contains a "dummy" big_step *)
val build_rew_display: t -> string -> G_graph.t -> Libgrew_types.rew_display
......
......@@ -154,4 +154,14 @@ module Parser = struct
pattern
with Sys_error msg -> Error.parse "[Grew_loader.Parser.pattern] %s" msg
(* ------------------------------------------------------------------------------------------*)
let strategy desc =
try
Global.init "Not a file";
let lexbuf = Lexing.from_string desc in
let strategy = parse_handle "Not a file" (Grew_parser.strategy Grew_lexer.global) lexbuf in
strategy
with Sys_error msg -> Error.parse "[Grew_loader.Parser.strategy] %s" msg
end
......@@ -10,6 +10,7 @@
open Grew_base
open Grew_types
open Grew_ast
module Loader: sig
......@@ -30,4 +31,6 @@ module Parser : sig
val phrase_structure_tree: string -> Ast.pst
val pattern: string -> Ast.pattern
val strategy: string -> Strategy.def
end
\ No newline at end of file
......@@ -118,6 +118,7 @@ let localize t = (t,get_loc ())
%start <Grew_ast.Ast.module_or_include list> included
%start <Grew_ast.Ast.pattern> pattern
%start <Grew_ast.Ast.domain> domain
%start <Grew_types.Strategy.def> strategy
/* parsing of the string representation of the constituent representation of Sequoia */
/* EX: "( (SENT (NP (NC Amélioration) (PP (P de) (NP (DET la) (NC sécurité))))))" */
......@@ -689,7 +690,7 @@ sequences:
| SEQUENCES seq=delimited(LACC,list(sequence),RACC) { seq }
sequence:
/* sequence { ant; p7_to_p7p-mc} */
/* seq_name { ant; p7_to_p7p-mc} */
| doc = option(COMMENT) id_loc=simple_id_with_loc mod_names=delimited(LACC,separated_list_final_opt(SEMIC,simple_id),RACC)
{ let (name,loc) = id_loc in
{
......@@ -700,7 +701,7 @@ sequence:
}
}
/* strat = <>(M1+M2)* */
| doc = option(COMMENT) id_loc=simple_id_with_loc EQUAL def=op_seq
| doc = option(COMMENT) id_loc=simple_id_with_loc EQUAL def=strat_def
{ let (name,loc) = id_loc in
{
Strategy.name;
......@@ -710,14 +711,15 @@ sequence:
}
}
op_seq:
| m=simple_id { Strategy.Ref m }
| LPAREN s=op_seq RPAREN { 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 }
strat_def:
| m=simple_id { Strategy.Ref m }
| LPAREN s=strat_def RPAREN { s }
| s=strat_def STAR { Strategy.Star (s) }
| s1=strat_def PLUS s2=strat_def { Strategy.Plus [s1; s2] }
| s1=strat_def SEMIC s2=strat_def { Strategy.Seq [s1; s2] }
| DISEQUAL s=strat_def { Strategy.Diamond s }
strategy: s = strat_def EOF { s }
/*=============================================================================================*/
/* ISOLATED PATTERN (grep mode) */
......
......@@ -34,7 +34,7 @@ module Instance = struct
let empty = {graph = G_graph.empty; rules=[]; history=[]; big_step=None; }
let from_graph graph = {empty with graph }
let from_graph graph = {empty with graph}
let rev_steps t =
{ t with big_step = match t.big_step with
......
......@@ -97,6 +97,7 @@ module Rule : sig
Instance_set.t * Instance_set.t
val one_step: ?domain: Domain.t -> string -> Instance.t -> t list -> Instance.t list
val conf_one_step: ?domain: Domain.t -> string -> Instance.t -> t list -> Instance.t option
(** the type matching encodes the graph morphism from a pattern to a graph *)
(* NB: it was made public for the grep mode *)
......
......@@ -268,6 +268,9 @@ module Rewrite = struct
let rewrite ~gr ~grs ~seq =
handle ~name:"Rewrite.rewrite" (fun () -> Grew_grs.Grs.rewrite grs seq gr) ()
let simple_rewrite ~gr ~grs ~strat =
handle ~name:"Rewrite.simple_rewrite" (fun () -> Grew_grs.Grs.simple_rewrite grs strat gr) ()
let get_graphs rh =
handle ~name:"Rewrite.get_graphs" (fun () -> Grew_grs.Rewrite_history.get_graphs rh) ()
......
......@@ -162,7 +162,7 @@ module Rewrite: sig
val rewrite: gr:Graph.t -> grs:Grs.t -> seq:string -> history
val get_graphs: history -> Graph.t list
val simple_rewrite: gr:Graph.t -> grs:Grs.t -> strat:string -> Graph.t list
val is_empty: history -> bool
......
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