Commit 60acc36a authored by bguillaum's avatar bguillaum

split Feature_structure in G_fs and P_fs

code cleaning


git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@6758 7838e531-6607-4d57-9587-6c381814729c
parent 11c31ce4
......@@ -163,7 +163,7 @@ module AST_HTML = struct
| 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.Param_feat (qfn, var) -> bprintf buff "param_feat %s @ %s" (string_of_qfn qfn) var)
| Ast.Param_feat (qfn, var) -> bprintf buff "param_feat %s = %s" (string_of_qfn qfn) var)
;
if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
......@@ -181,7 +181,7 @@ module AST_HTML = struct
match u_feature.Ast.kind with
| Ast.Equality values -> bprintf buff " = %s" (List_.to_string (fun x->x) ", " values)
| Ast.Disequality values -> bprintf buff " <> %s" (List_.to_string (fun x->x) ", " values)
| Ast.Param index -> bprintf buff "@%s" index
| Ast.Param index -> bprintf buff " = %s" index
let buff_html_node buff (u_node,_) =
bprintf buff " %s [" u_node.Ast.node_id;
......
......@@ -49,7 +49,7 @@ module Command = struct
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
let build ?cmd_vars ?domain (kni, kei) table locals ast_command =
let build ?cmd_vars (kni, kei) table locals ast_command =
let get_pid node_name =
match Id.build_opt node_name table with
| Some id -> Pid id
......
......@@ -45,7 +45,6 @@ module Command : sig
val build:
?cmd_vars: string list ->
?domain:Ast.domain ->
(string list * string list) ->
Id.table ->
Label.decl array ->
......
......@@ -33,7 +33,6 @@ end
(* ================================================================================ *)
(* ================================================================================ *)
module G_edge = struct
type t = Label.t
......@@ -101,9 +100,6 @@ module P_edge = struct
| Pos p -> List_.sort_mem g_edge p
| Neg n -> not (List_.sort_mem g_edge n)
type edge_matcher =
| Fail
| Ok of Label.t
......
open Grew_utils
open Grew_ast
(* ================================================================================ *)
(** The module [Label] defines the type of atomic label edges *)
module Label : sig
(* a label declaration: (the label,an optionnal color) *)
type decl = string * string option
......@@ -9,11 +12,10 @@ module Label : sig
val init: decl list -> unit
val to_string:t -> string
val to_string: t -> string
val to_int: t -> int
val from_string: ?loc:Loc.t -> ?locals:decl array -> string -> t
val from_string: ?loc:Loc.t -> ?locals:decl array -> string -> t
end
......@@ -31,7 +33,6 @@ module G_edge: sig
val to_dot: ?deco:bool -> t -> string
val to_dep: ?deco:bool -> t -> string
end
(* ================================================================================ *)
......
This diff is collapsed.
open Grew_utils
open Grew_ast
module Feature: sig
val check: ?domain:Ast.domain -> Loc.t -> string -> string list -> unit
module Domain: sig
val reset: unit -> unit
val init: Ast.domain -> unit
end
module Feature_structure: sig
(* [G_fs] define the ferute srtuctures that are used in graphs *)
module G_fs: sig
type t
val build: ?pat_vars: string list -> ?domain:Ast.domain -> Ast.feature list -> t
val of_conll: Conll.line -> t
val empty: t
(** [set_feat feature_name atom t] adds the feature ([feature_name],[atom]) in [t].
If [t] already contains a feature named [feature_name], the old value is erased by the new one. *)
val set_feat: ?loc:Loc.t -> string -> string -> t -> t
(** [del_feat feature_name t] remove the feature with name [feature_name] in [t].
If [t] does not contain such a feature, [t] is returned unchanged. *)
val del_feat: string -> t -> t
val get: string -> t -> string list option
(** [get_atom f t] returns [Some v] if the fs [t] contains the feature (f,v).
It returns [None] if there is no feature named [f] in [t] *)
val get_atom: string -> t -> string option
val empty: t
val to_string: t -> string
val to_dot: ?main_feat: string -> t -> string
val to_gr: t -> string
val to_dep: ?main_feat: string -> t -> string
val to_gr: t -> string
val to_dot: ?main_feat: string -> t -> string
val to_dep: ?main_feat: string -> t -> string
val to_string: t -> string
val build: Ast.feature list -> t
(** [set_feat feature_name atoms t] adds the feature ([feature_name],[atoms]) in [t].
If [t] already contains a feature named [feature_name], the old value is erased by the new one. *)
val set_feat: string -> string list -> t -> t
val of_conll: Conll.line -> t
(** [del_feat feature_name t] remove the feature with name [feature_name] in [t].
If [t] does not contain such a feature, [t] is returned unchanged. *)
val del_feat: string -> t -> t
(** [unif t1 t2] returns [Some t] if [t] is the unification of two graph feature structures
[None] is returned if the two feature structures cannot be unified. *)
val unif: t -> t -> t option
end
module P_fs: sig
type t
val compatible: t -> t -> bool
val empty: t
val build: ?pat_vars: string list -> Ast.feature list -> t
val to_string: t -> string
val compatible_param: (string list * string list) list -> t -> t -> (string list * string list) list
val to_dot: t -> string
(** [unif t1 t2] returns [Some t] if [t] is the unification of two graph feature structures
[None] is returned if the two feature structures cannot be unified
[Bug_unif <msg>] is raised if inputs are not correct graph feature structures *)
val unif: t -> t -> t option
exception Fail
val unifiable: t -> t -> bool
val filter: t -> t -> bool
end
(** [match_ ?param t gfs] tries to match the pattern fs [pfs] with the graph fs [gfs]
If [param] is [None], it returns [None] if matching succeeds and else raise [Fail].
If [param] is [Some p], it returns [Some p'] if matching succeeds and else raise [Fail].
*)
val match_: ?param:Lex_par.t -> t -> G_fs.t -> Lex_par.t option
val filter: t -> G_fs.t -> bool
end
......@@ -36,12 +36,12 @@ module P_graph = struct
| None -> None
| Some new_node -> Some (Pid_map.add id_src new_node map)
let build_filter ?domain table (ast_node, loc) =
let build_filter 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
let fs = P_fs.build ast_node.Ast.fs in
(pid, fs)
let build ?pat_vars ?domain ?(locals=[||]) full_node_list full_edge_list =
let build ?pat_vars ?(locals=[||]) full_node_list full_edge_list =
let (named_nodes, constraints) =
let rec loop already_bound = function
......@@ -50,11 +50,9 @@ module P_graph = struct
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 ?domain (ast_node, loc) :: tail_nodes, tail_const) in
else (P_node.build ?pat_vars (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,7 +75,7 @@ module P_graph = struct
(Loc.to_string loc)
)
) map_without_edges full_edge_list in
(map, table, List.map (build_filter ?domain table) constraints)
(map, table, List.map (build_filter 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" *)
......@@ -86,9 +84,9 @@ module P_graph = struct
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
let build_extension ?domain ?(locals=[||]) old_table full_node_list full_edge_list =
let build_extension ?(locals=[||]) old_table full_node_list full_edge_list =
let built_nodes = List.map (P_node.build ?domain) full_node_list in
let built_nodes = List.map P_node.build full_node_list in
let (old_nodes, new_nodes) =
List.partition
......@@ -203,7 +201,7 @@ module G_graph = struct
| None -> None
| Some new_node -> Some (Gid_map.add id_src new_node map)
let build ?domain ?(locals=[||]) full_node_list full_edge_list =
let build ?(locals=[||]) full_node_list full_edge_list =
let named_nodes =
let rec loop already_bound = function
......@@ -212,7 +210,7 @@ module G_graph = struct
let tail = loop (ast_node.Ast.node_id :: already_bound) tail in
if List.mem ast_node.Ast.node_id already_bound
then Log.fcritical "[GRS] [Graph.build] try to build a graph with twice the same node id '%s'" ast_node.Ast.node_id
else G_node.build ?domain (ast_node, loc) :: tail in
else G_node.build (ast_node, loc) :: tail in
loop [] full_node_list in
let sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) named_nodes in
......@@ -404,7 +402,7 @@ module G_graph = struct
let src_node = Gid_map.find src_gid se_graph.map in
let tar_node = Gid_map.find tar_gid se_graph.map in
match Feature_structure.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
match G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
| Some new_fs ->
let new_map =
Gid_map.add
......@@ -415,19 +413,20 @@ module G_graph = struct
| None -> None
(* FIXME: check consistency wrt the domain *)
let set_feat graph node_id feat_name new_value =
let set_feat ?loc graph node_id feat_name new_value =
printf "===DEBUG=== loc:%s\n%!" (match loc with None -> "None" | Some l -> Loc.to_string l);
let node = Gid_map.find node_id graph.map in
let new_fs = Feature_structure.set_feat feat_name [new_value] (G_node.get_fs node) in
let new_fs = G_fs.set_feat ?loc feat_name new_value (G_node.get_fs node) in
{graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map}
let update_feat graph tar_id tar_feat_name item_list =
let update_feat ?loc graph tar_id tar_feat_name item_list =
let strings_to_concat =
List.map
(function
| Feat (node_gid, feat_name) ->
let node = Gid_map.find node_gid graph.map in
(try
match Feature_structure.get_atom feat_name (G_node.get_fs node) with
match G_fs.get_atom feat_name (G_node.get_fs node) with
| Some atom -> atom
| None -> Log.fcritical "[BUG] [Graph.update_feat] Feature not atomic"
with Not_found ->
......@@ -436,11 +435,7 @@ module G_graph = struct
| String s -> s
) item_list in
let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
(set_feat graph tar_id tar_feat_name new_feature_value, new_feature_value)
(* let tar = Gid_map.find tar_id graph.map in *)
(* let new_fs = Feature_structure.set_feat tar_feat_name [new_feature_value] (G_node.get_fs tar) in *)
(* ({graph with map = Gid_map.add tar_id (G_node.set_fs tar new_fs) graph.map}, new_feature_value) *)
(set_feat ?loc graph tar_id tar_feat_name new_feature_value, new_feature_value)
......@@ -448,7 +443,7 @@ module G_graph = struct
If the feature is not present, [graph] is returned. *)
let del_feat graph node_id feat_name =
let node = Gid_map.find node_id graph.map in
let new_fs = Feature_structure.del_feat feat_name (G_node.get_fs node) in
let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
{graph with map = Gid_map.add node_id (* {node with Node.fs = new_fs} *) (G_node.set_fs node new_fs) graph.map}
let to_gr graph =
......@@ -486,9 +481,9 @@ module G_graph = struct
(fun (id, node) ->
if List.mem id deco.Deco.nodes
then bprintf buff
"N%d { %sforecolor=red; subcolor=red; }\n" id (Feature_structure.to_dep ?main_feat (G_node.get_fs node))
"N%d { %sforecolor=red; subcolor=red; }\n" id (G_fs.to_dep ?main_feat (G_node.get_fs node))
else bprintf buff
"N%d { %s }\n" id (Feature_structure.to_dep ?main_feat (G_node.get_fs node))
"N%d { %s }\n" id (G_fs.to_dep ?main_feat (G_node.get_fs node))
) snodes;
bprintf buff "} \n";
......@@ -516,7 +511,7 @@ module G_graph = struct
(fun id node ->
bprintf buff " N%d [label=\"%s\", color=%s]\n"
id
(Feature_structure.to_dot ?main_feat (G_node.get_fs node))
(G_fs.to_dot ?main_feat (G_node.get_fs node))
(if List.mem id deco.Deco.nodes then "red" else "black")
) graph.map;
(* list of the edges *)
......
......@@ -26,14 +26,12 @@ module P_graph: sig
val build:
?pat_vars: string list ->
?domain: Ast.domain ->
?locals: Label.decl array ->
Ast.node list ->
Ast.edge list ->
(t * Id.table * (Id.t * Feature_structure.t) list )
(t * Id.table * (Id.t * P_fs.t) list )
val build_extension:
?domain: Ast.domain ->
?locals: Label.decl array ->
Id.table ->
Ast.node list ->
......@@ -61,7 +59,6 @@ module G_graph: sig
val find: Gid.t -> t -> G_node.t
val build:
?domain: Ast.domain ->
?locals: Label.decl array ->
Ast.node list ->
Ast.edge list ->
......@@ -92,11 +89,11 @@ module G_graph: sig
(** [update_feat tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
It returns both the new graph and the new feature value produced as the second element *)
val update_feat : t -> int -> string -> concat_item list -> (t * string)
val update_feat: ?loc:Loc.t -> t -> int -> string -> concat_item list -> (t * string)
val set_feat: t -> int -> string -> string -> t
val set_feat: ?loc:Loc.t -> t -> int -> string -> string -> t
val del_feat : t -> int -> string -> t
val del_feat: t -> int -> string -> t
(** [edge_out t id edge] returns true iff there is an out-edge from the node [id] with a label compatible with [edge] *)
val edge_out: t -> int -> P_edge.t -> bool
......
open Printf
open Log
open Grew_fs
open Grew_utils
open Grew_ast
open Grew_edge
......@@ -162,7 +163,7 @@ module Modul = struct
| r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
loop [] t.rules
let build ?domain ast_module =
let build ast_module =
let locals = Array.of_list ast_module.Ast.local_labels in
Array.sort compare locals;
let modul =
......@@ -170,7 +171,7 @@ module Modul = struct
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;
rules = List.map (Rule.build ~locals) ast_module.Ast.rules;
confluent = ast_module.Ast.confluent;
loc = ast_module.Ast.mod_loc;
} in
......@@ -234,7 +235,8 @@ module Grs = struct
let build ast_grs =
Label.init ast_grs.Ast.labels;
let modules = List.map (Modul.build ~domain:ast_grs.Ast.domain) ast_grs.Ast.modules in
Domain.init ast_grs.Ast.domain;
let modules = List.map Modul.build ast_grs.Ast.modules in
let grs = {
labels = List.map (fun (l,_) -> Label.from_string l) ast_grs.Ast.labels;
modules = modules;
......@@ -267,7 +269,7 @@ module Grs = struct
Rule.normalize
~confluent: next.Modul.confluent
next.Modul.rules
(fun x -> true) (* FIXME *)
(fun x -> true) (* FIXME filter at the end of rewriting modules *)
(Instance.clear instance) in
let good_list = Instance_set.elements good_set
and bad_list = Instance_set.elements bad_set in
......
......@@ -8,7 +8,7 @@ open Grew_fs
(* ================================================================================ *)
module G_node = struct
type t = {
fs: Feature_structure.t;
fs: G_fs.t;
pos: int option;
next: G_edge.t Massoc.t;
}
......@@ -18,32 +18,32 @@ module G_node = struct
let set_fs t fs = {t with fs = fs}
let empty = { fs = Feature_structure.empty; pos = None; next = Massoc.empty }
let empty = { fs = G_fs.empty; pos = None; next = Massoc.empty }
let to_string t =
Printf.sprintf "[fs=%s ; next=%s]"
(Feature_structure.to_string t.fs)
(G_fs.to_string t.fs)
(Massoc.to_string G_edge.to_string t.next)
let to_gr t =
sprintf "%s [%s] "
(match t.pos with Some i -> sprintf "(%d)" i | None -> "")
(Feature_structure.to_gr t.fs)
(G_fs.to_gr t.fs)
let add_edge g_edge gid_tar t =
match Massoc.add gid_tar g_edge t.next with
| Some l -> Some {t with next = l}
| None -> None
let build ?domain (ast_node, loc) =
let build (ast_node, loc) =
(ast_node.Ast.node_id,
{ fs = Feature_structure.build ?domain ast_node.Ast.fs;
{ fs = G_fs.build ast_node.Ast.fs;
pos = ast_node.Ast.position;
next = Massoc.empty;
} )
let of_conll line = {
fs = Feature_structure.of_conll line;
fs = G_fs.of_conll line;
pos = Some line.Conll.num;
next = Massoc.empty;
}
......@@ -74,18 +74,18 @@ end
(* ================================================================================ *)
module P_node = struct
type t = {
fs: Feature_structure.t;
fs: P_fs.t;
next: P_edge.t Massoc.t;
}
let get_fs t = t.fs
let get_next t = t.next
let empty = { fs = Feature_structure.empty; next = Massoc.empty }
let empty = { fs = P_fs.empty; next = Massoc.empty }
let build ?pat_vars ?domain (ast_node, loc) =
let build ?pat_vars (ast_node, loc) =
(ast_node.Ast.node_id,
{ fs = Feature_structure.build ?pat_vars ?domain ast_node.Ast.fs;
{ fs = P_fs.build ?pat_vars ast_node.Ast.fs;
next = Massoc.empty;
} )
......@@ -94,10 +94,8 @@ module P_node = struct
| Some l -> Some {t with next = l}
| None -> None
(* Says that "pattern" t1 is a t2*)
let is_a p_node g_node = Feature_structure.compatible p_node.fs (G_node.get_fs g_node)
let match_ ?param p_node g_node = P_fs.match_ ?param p_node.fs (G_node.get_fs g_node)
let is_a_param param p_node g_node = Feature_structure.compatible_param param p_node.fs (G_node.get_fs g_node)
end
(* ================================================================================ *)
......
......@@ -12,10 +12,10 @@ module G_node: sig
val to_string: t -> string
val to_gr: t -> string
val get_fs: t -> Feature_structure.t
val get_fs: t -> G_fs.t
val get_next: t -> G_edge.t Massoc.t
val set_fs: t -> Feature_structure.t -> t
val set_fs: t -> G_fs.t -> t
(* FIXME move Gid up and replace int by Gid.t *)
val remove: int -> G_edge.t -> t -> t
......@@ -28,7 +28,7 @@ module G_node: sig
val rm_out_edges: t -> t
val add_edge: G_edge.t -> int -> t -> t option
val build: ?domain:Ast.domain -> Ast.node -> (Id.name * t)
val build: Ast.node -> (Id.name * t)
val of_conll: Conll.line -> t
val pos_comp: t -> t -> int
......@@ -43,15 +43,14 @@ module P_node: sig
val empty: t
val get_fs: t -> Feature_structure.t
val get_fs: t -> P_fs.t
val get_next: t -> P_edge.t Massoc.t
val build: ?pat_vars: string list -> ?domain:Ast.domain -> Ast.node -> (Id.name * t)
val build: ?pat_vars: string list -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> int -> t -> t option
val is_a: t -> G_node.t -> bool
val match_: ?param: Lex_par.t -> t -> G_node.t -> Lex_par.t option
val is_a_param: (string list * string list) list -> t -> G_node.t -> (string list * string list) list
end
(* ================================================================================ *)
This diff is collapsed.
......@@ -41,7 +41,7 @@ module Rule : sig
val get_loc: t -> Loc.t
val build: ?domain:Ast.domain -> ?locals:Label.decl array -> Ast.rule -> t
val build: ?locals:Label.decl array -> Ast.rule -> t
(* raise Stop if some command fails to apply *)
val normalize:
......
......@@ -25,5 +25,5 @@ and big_step = {
}
let to_dot_graph ?main_feat ?(deco=Deco.empty) graph = G_graph.to_dot ?main_feat graph ~deco
let to_dep_graph ?main_feat ?(deco=Deco.empty) graph = G_graph.to_dep ?main_feat ~deco graph
let to_dep_graph ?main_feat ?(deco=Deco.empty) graph = G_graph.to_dep ?main_feat ~deco graph
let to_gr_graph graph = G_graph.to_gr graph
......@@ -189,12 +189,6 @@ module List_ = struct
| [] -> ""
| h::t -> List.fold_left (fun acc elt -> acc ^ sep ^ (string_of_item elt)) (string_of_item h) t
let rec sort_mem elt = function
| [] -> false
| h::t when elt<h -> false
| h::t when elt>h -> sort_mem elt t
| _ -> (* elt=h *) true
let rec sort_insert elt = function
| [] -> [elt]
| h::t when elt<h -> elt::h::t
......@@ -205,6 +199,20 @@ module List_ = struct
| h::_ when elt<h -> false
| h::_ when elt=h -> true
| h::t (* when elt>h *) -> sort_mem elt t
let rec sort_assoc key = function
| [] -> None
| (k,_)::_ when key<k -> None
| (k,_)::t when key>k -> sort_assoc key t
| (_,v)::_ -> Some v
let rec sort_remove_assoc key = function
| [] -> []
| (k,_)::_ as t when key<k -> t
| (k,v)::t when key>k -> (k,v) :: (sort_remove_assoc key t)
| (_,v)::t -> t
exception Usort
let rec usort_remove key = function
......@@ -484,3 +492,46 @@ module Conll = struct
}
| _ -> Log.fcritical "Cannot not parse CONLL line '%s'" line
end
(* This module defiens 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 *)
type t = item list
let load ?loc nb_p nb_c file =
try
let lines = File.read file in
let param =
(List.map
(fun line ->
match Str.split (Str.regexp "##") line with
| [args] when nb_c = 0 ->
(match Str.split (Str.regexp "#") args with
| l when List.length l = nb_p -> (l,[])
| _ -> Error.bug "Illegal param line in file '%s' line '%s' hasn't %d args" file line nb_p)
| [args; values] ->
(match (Str.split (Str.regexp "#") args, Str.split (Str.regexp "#") values) with
| (lp,lc) when List.length lp = nb_p && List.length lc = nb_c -> (lp,lc)
| _ -> Error.bug "Illegal param line in file '%s' line '%s' hasn't %d args and %d values" file line nb_p nb_c)
| _ -> Error.bug "Illegal param line in file '%s' line '%s'" file line
) lines
) in
param
with Sys_error _ -> Error.build ?loc "External lexical file '%s' not found" file
let filter index atom t =
(match List.filter (fun (x,_) -> List.nth x index = atom) t with
| [] -> None
| t' -> Some t'
)
let get_command_value index = function
| [(_,one)] -> List.nth one index
| [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
| l -> Error.run "Lexcial parameter are not functionnal"
end
......@@ -76,6 +76,12 @@ module List_: sig
val sort_included_diff: 'a list -> 'a list -> 'a list
val sort_diff: 'a list -> 'a list -> 'a list
val sort_assoc: 'a -> ('a * 'b) list -> 'b option
(* [sort_remove_assoc k ass_list] returns the input list without the [key] element,
if [key] not found, the unchanged input list is returned *)