Commit b2797167 authored by Bruno Guillaume's avatar Bruno Guillaume

Rearrange modules

parent e9b2538d
......@@ -143,7 +143,7 @@ grew_ast.cmx: $(GREW_AST_CMX) grew_ast.cmi grew_ast.ml
###### grew_html.ml ##############################################################
GREW_HTML_DEP = grew_base grew_ast grew_rule grew_grs
GREW_HTML_DEP = grew_base grew_types grew_ast grew_rule grew_grs
GREW_HTML_CMI = $(GREW_HTML_DEP:%=%.cmi)
GREW_HTML_CMO = $(GREW_HTML_DEP:%=%.cmo)
GREW_HTML_CMX = $(GREW_HTML_DEP:%=%.cmx)
......
......@@ -11,6 +11,7 @@
open Printf
open Log
open Grew_base
open Grew_types
(* ================================================================================ *)
module Ast = struct
......@@ -19,12 +20,7 @@ module Ast = struct
| [one] -> one
| _ -> Error.build "The identifier '%s' contains the '.' symbol" s
type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
type suffix = string
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type complex_id =
| No_sharp of string
......@@ -34,7 +30,7 @@ module Ast = struct
| No_sharp x -> x
| Sharp (x,y) -> x ^ "#" ^ y
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* simple_id: V *)
type simple_id = Id.name
......@@ -45,7 +41,7 @@ module Ast = struct
| No_sharp s when List.length (dot_split s) = 1 -> true
| _ -> false
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* label_id: p_obj.loc x.y.z *)
type label_id = string
......@@ -53,7 +49,7 @@ module Ast = struct
| No_sharp s -> s
| Sharp _ -> Error.build "The identifier '%s' must be a label (without '#' symbol)" (complex_id_to_string ci)
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* act_id: V, V#alpha *)
type act_id = Id.name * string option
......@@ -65,7 +61,7 @@ module Ast = struct
| (base, None) -> base
| (base, Some ln) -> sprintf "%s#%s" base ln
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* simple_qfn: V.cat *)
type simple_qfn = Id.name * feature_name
let simple_qfn_of_ci ci = match ci with
......@@ -78,7 +74,7 @@ module Ast = struct
let simple_qfn_to_string (name, feat_name) = sprintf "%s.%s" name feat_name
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* act_qfn: V.cat, V#alpha.cat *)
type act_qfn = act_id * feature_name
......@@ -94,31 +90,6 @@ module Ast = struct
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Int of feature_name (* position *)
type domain = feature_spec list
let is_defined feature_name domain =
List.exists (function
| Closed (fn,_) when fn = feature_name -> true
| Open fn when fn = feature_name -> true
| Int fn when fn = feature_name -> true
| _ -> false
) domain
let rec normalize_domain = function
| [] -> [Int "position"]
| (Int "position") :: tail -> Log.warning "[Domain] declaration of the feature name \"position\" in useless"; normalize_domain tail
| (Open "position") :: _
| (Closed ("position",_)) :: _ ->
Error.build "[Domain] The feature named \"position\" is reserved and must be types 'integer', you cannot not redefine it"
| (Int fn) :: tail | (Open fn) :: tail | Closed (fn,_) :: tail when is_defined fn tail ->
Error.build "[Domain] The feature named \"%s\" is defined several times" fn
| x :: tail -> x :: (normalize_domain tail)
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
......@@ -239,14 +210,14 @@ module Ast = struct
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: domain;
domain_wi: Domain.domain;
labels_wi: (string * string list) list; (* the list of global edge labels *)
modules_wi: module_or_include list;
sequences_wi: sequence list;
}
type grs = {
domain: domain;
domain: Domain.domain;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
......
......@@ -12,7 +12,6 @@ open Grew_base
open Grew_types
module Ast : sig
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type complex_id =
......@@ -43,14 +42,6 @@ module Ast : sig
type act_qfn = act_id * feature_name
val act_qfn_of_ci: complex_id -> act_qfn
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Int of feature_name (* position *)
type domain = feature_spec list
val normalize_domain: domain -> domain
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
......@@ -156,7 +147,7 @@ module Ast : sig
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: domain;
domain_wi: Domain.domain;
labels_wi: (string * string list) list; (* the list of global edge labels *)
modules_wi: module_or_include list;
sequences_wi: sequence list;
......@@ -164,7 +155,7 @@ module Ast : sig
(* a GRS: graph rewriting system *)
type grs = {
domain: domain;
domain: Domain.domain;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
......
......@@ -11,11 +11,11 @@
open Log
open Printf
module StringSet = Set.Make (String)
module StringMap = Map.Make (String)
module String_set = Set.Make (String)
module String_map = 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 Int_set = Set.Make (struct type t = int let compare = Pervasives.compare end)
module Int_map = Map.Make (struct type t = int let compare = Pervasives.compare end)
(* ================================================================================ *)
module Loc = struct
......@@ -72,7 +72,6 @@ module Dot = struct
ignore(Sys.command(sprintf "dot -Tpng -o %s %s " output_file temp_file_name))
end (* module Dot *)
(* ================================================================================ *)
module File = struct
let write data name =
......@@ -348,56 +347,54 @@ module List_ = struct
end (* module List_ *)
(* ================================================================================ *)
module type OrderedType =
sig
type t
val compare: t -> t -> int
end (* module type OrderedType *)
module type OrderedType = sig
type t
val compare: t -> t -> int
end (* module type OrderedType *)
(* ================================================================================ *)
module type S =
sig
type key
module type S = sig
type key
type +'a t
type +'a t
val empty: 'a t
val empty: 'a t
(* an empty list returned if the key is undefined *)
val assoc: key -> 'a t -> 'a list
(* an empty list returned if the key is undefined *)
val assoc: key -> 'a t -> 'a list
val is_empty: 'a t -> bool
val is_empty: 'a t -> bool
val to_string: ('a -> string) -> 'a t -> string
val to_string: ('a -> string) -> 'a t -> string
val iter: (key -> 'a -> unit) -> 'a t -> unit
val iter: (key -> 'a -> unit) -> 'a t -> unit
val add: key -> 'a -> 'a t -> 'a t option
val add: key -> 'a -> 'a t -> 'a t option
val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
(* raise Not_found if no (key,elt) *)
val remove: key -> 'a -> 'a t -> 'a t
(* raise Not_found if no (key,elt) *)
val remove: key -> 'a -> 'a t -> 'a t
(* raise Not_found if no (key,elt) *)
val remove_key: key -> 'a t -> 'a t
(* raise Not_found if no (key,elt) *)
val remove_key: key -> 'a t -> 'a t
(* [mem key value t ] test if the couple (key, value) is in the massoc [t]. *)
val mem: key -> 'a -> 'a t -> bool
(* [mem key value t ] test if the couple (key, value) is in the massoc [t]. *)
val mem: key -> 'a -> 'a t -> bool
(* mem_key key t] tests is [key] is associated to at least one value in [t]. *)
val mem_key: key -> 'a t -> bool
(* mem_key key t] tests is [key] is associated to at least one value in [t]. *)
val mem_key: key -> 'a t -> bool
exception Not_disjoint
val disjoint_union: 'a t -> 'a t -> 'a t
exception Not_disjoint
val disjoint_union: 'a t -> 'a t -> 'a t
exception Duplicate
val merge_key: key -> key -> 'a t -> 'a t
exception Duplicate
val merge_key: key -> key -> 'a t -> 'a t
val exists: (key -> 'a -> bool) -> 'a t -> bool
val exists: (key -> 'a -> bool) -> 'a t -> bool
val rename: (key * key) list -> 'a t -> 'a t
end (* module type S *)
val rename: (key * key) list -> 'a t -> 'a t
end (* module type S *)
(* ================================================================================ *)
module Massoc_make (Ord: OrderedType) = struct
......@@ -477,15 +474,6 @@ module Massoc_make (Ord: OrderedType) = struct
| Not_found -> (* no key i *) t
| List_.Not_disjoint -> raise Duplicate
(* New implementation of exists but exists fct not implemented in ocaml < 3.12 *)
(*
let exists fct t =
M.exists
(fun key list ->
List.exists (fun elt -> fct key elt) list
) t
*)
exception True
let exists fct t =
try
......@@ -503,7 +491,6 @@ module Massoc_make (Ord: OrderedType) = struct
let new_key = try List.assoc key mapping with Not_found -> key in
M.add new_key value acc
) t M.empty
end (* module Massoc_make *)
(* ================================================================================ *)
......@@ -525,7 +512,10 @@ end (* module Id *)
(* ================================================================================ *)
module Html = struct
let css = "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n<link rel=\"stylesheet\" href=\"style.css\" type=\"text/css\">"
let css = String.concat "\n" [
"<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />";
"<link rel=\"stylesheet\" href=\"style.css\" type=\"text/css\">"
]
let enter out_ch ?title ?header base_name =
fprintf out_ch "<html>\n";
......@@ -541,6 +531,7 @@ module Html = struct
| Some t -> fprintf out_ch "<h1>%s</h1>\n" t
| None -> ()
)
let leave out_ch =
fprintf out_ch "</body>\n";
fprintf out_ch "</html>\n";
......
......@@ -8,11 +8,11 @@
(* Authors: see AUTHORS file *)
(**********************************************************************************)
module StringMap : Map.S with type key = string
module StringSet : Set.S with type elt = string
module String_map : Map.S with type key = string
module String_set : Set.S with type elt = string
module IntSet : Set.S with type elt = int
module IntMap : Map.S with type key = int
module Int_set : Set.S with type elt = int
module Int_map : Map.S with type key = int
(* ================================================================================ *)
(* [Pid_set] *)
......
......@@ -15,62 +15,6 @@ open Grew_base
open Grew_types
open Grew_ast
type value = String of string | Float of float
let string_of_value = function
| String s -> Str.global_replace (Str.regexp "\"") "\\\""
(Str.global_replace (Str.regexp "\\\\") "\\\\\\\\" s)
| Float i -> String_.of_float i
let conll_string_of_value = function
| String s -> s
| Float i -> String_.of_float i
(* ==================================================================================================== *)
module Domain = struct
let current = ref None
let reset () = current := None
let init ast_domain =
current := Some (Ast.normalize_domain ast_domain)
let build ?loc name unsorted_values =
let values = List.sort Pervasives.compare unsorted_values in
match (name.[0], !current) with
| ('_', _) (* no check on feat_name starting with '_' *)
| (_, None) -> List.map (fun s -> String s) values (* no domain defined *)
| (_, Some dom) ->
let rec loop = function
| [] -> Error.build ?loc "[GRS] Unknown feature name '%s'" name
| ((Ast.Open n)::_) when n = name ->
List.map (fun s -> String s) values
| ((Ast.Int n)::_) when n = name ->
(try List.map (fun s -> Float (String_.to_float s)) values
with Failure _ -> Error.build ?loc "[GRS] The feature '%s' is of type int" name)
| ((Ast.Closed (n,vs))::_) when n = name ->
(match List_.sort_diff values vs with
| [] -> List.map (fun s -> String s) values
| l when List.for_all (fun x -> x.[0] = '_') l -> List.map (fun s -> String s) values
| l -> Error.build ?loc "Unknown feature values '%s' for feature name '%s'"
(List_.to_string (fun x->x) ", " l)
name
)
| _::t -> loop t in
loop dom
let build_one ?loc name value =
match build ?loc name [value] with
| [x] -> x
| _ -> Error.bug ?loc "[Domain.build_one]"
let feature_names () =
match !current with
| None -> None
| Some dom -> Some (List.map (function Ast.Closed (fn, _) | Ast.Open fn | Ast.Int fn -> fn) dom)
end
(* ==================================================================================================== *)
module G_feature = struct
......
......@@ -10,18 +10,10 @@
open Grew_base
open Grew_types
open Grew_ast
module Domain: sig
val reset: unit -> unit
val init: Ast.domain -> unit
val feature_names: unit -> string list option
end
(* [G_fs] define the feature srtuctures that are used in graphs *)
(* ================================================================================ *)
(* module [G_fs] defines the feature structures that are used in graphs *)
module G_fs: sig
type t
......@@ -61,8 +53,10 @@ module G_fs: sig
(** [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
end (* module G_fs *)
(* ================================================================================ *)
(* module [P_fs] defines the feature structures that are used in patterns *)
module P_fs: sig
type t
......@@ -93,4 +87,4 @@ module P_fs: sig
val filter: t -> G_fs.t -> bool
val unif: t -> t -> t
end
end (* module P_fs *)
......@@ -19,9 +19,7 @@ open Grew_edge
open Grew_fs
open Grew_node
module Str_map = Map.Make (String)
(* ==================================================================================================== *)
(* ================================================================================ *)
module P_deco = struct
type t = {
nodes: Pid.t list;
......@@ -31,7 +29,7 @@ module P_deco = struct
let empty = {nodes=[]; edges=[]}
end (* module P_deco *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module P_graph = struct
type t = P_node.t Pid_map.t
......@@ -189,7 +187,7 @@ module P_graph = struct
let roots graph = snd (tree_and_roots graph)
end (* module P_graph *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module G_deco = struct
type t = {
nodes: (Gid.t * (string * string list)) list; (* a list of (node, (pattern_id, features of nodes implied in the step)) *)
......@@ -217,21 +215,21 @@ module G_deco = struct
) t.edges
end (* module G_deco *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module Concat_item = struct
type t =
| Feat of (Gid.t * string)
| String of string
end (* module Concat_item *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module G_graph = struct
type t = {
meta: (string * string) list;
map: G_node.t Gid_map.t; (* node description *)
}
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
let rename mapping graph =
{graph with map =
Gid_map.fold
......@@ -242,7 +240,7 @@ module G_graph = struct
) graph.map Gid_map.empty
}
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* [normalize g] changes all graphs keys to Old _ (used when entering a new module) *)
let normalize t =
let (_, mapping) =
......@@ -310,10 +308,7 @@ module G_graph = struct
| Some new_map -> Some {graph with map = new_map }
| None -> None
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Build functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* -------------------------------------------------------------------------------- *)
let build ?(locals=[||]) gr_ast =
let full_node_list = gr_ast.Ast.nodes
and full_edge_list = gr_ast.Ast.edges in
......@@ -396,7 +391,8 @@ module G_graph = struct
try Some (List.assoc name atts)
with Not_found -> None
(** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *)
(* -------------------------------------------------------------------------------- *)
(** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *)
let of_xml d_xml =
match d_xml with
| Xml.Element ("D", _, t_or_r_list) ->
......@@ -414,9 +410,9 @@ module G_graph = struct
G_fs.empty
(("phon", phon) :: ("cat", (List.assoc "label" t_atts)) :: other_feats) in
let new_node = G_node.set_fs (G_node.set_position (float i) G_node.empty) new_fs in
(Gid_map.add (Gid.Old i) new_node acc, Str_map.add id (Gid.Old i) acc_map)
(Gid_map.add (Gid.Old i) new_node acc, String_map.add id (Gid.Old i) acc_map)
| _ -> Log.critical "[G_graph.of_xml] Not a wellformed <T> tag"
) (Gid_map.empty, Str_map.empty) t_list in
) (Gid_map.empty, String_map.empty) t_list in
let final_map =
List.fold_left
(fun acc r_xml ->
......@@ -425,8 +421,8 @@ module G_graph = struct
let src = List.assoc "from" r_atts
and tar = List.assoc "to" r_atts
and label = List.assoc "label" r_atts in
let gid_tar = Str_map.find tar mapping in
let gid_src = Str_map.find src mapping in
let gid_tar = String_map.find tar mapping in
let gid_src = String_map.find src mapping in
let old_node = Gid_map.find gid_src acc in
let new_map =
match G_node.add_edge (G_edge.make label) gid_tar old_node with
......@@ -438,10 +434,6 @@ module G_graph = struct
{meta=[]; map=final_map}
| _ -> Log.critical "[G_graph.of_xml] Not a <D> tag"
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Update functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* -------------------------------------------------------------------------------- *)
let del_edge ?edge_ident loc graph id_src label id_tar =
let node_src =
......@@ -620,10 +612,6 @@ module G_graph = struct
let new_fs = G_fs.del_feat feat_name (G_node.get_fs node) in
{ graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map }
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Output functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* -------------------------------------------------------------------------------- *)
let to_gr graph =
let buff = Buffer.create 32 in
......
This diff is collapsed.
......@@ -18,6 +18,17 @@ type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
type suffix = string
type value = String of string | Float of float
let string_of_value = function
| String s -> Str.global_replace (Str.regexp "\"") "\\\""
(Str.global_replace (Str.regexp "\\\\") "\\\\\\\\" s)
| Float i -> String_.of_float i
let conll_string_of_value = function
| String s -> s
| Float i -> String_.of_float i
(* ================================================================================ *)
module Pid = struct
(* type t = int *)
......@@ -203,6 +214,75 @@ module Label = struct
with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string
end (* module Label *)
(* ==================================================================================================== *)
module Domain = struct
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Int of feature_name (* position *)
type domain = feature_spec list
let is_defined feature_name domain =
List.exists (function
| Closed (fn,_) when fn = feature_name -> true
| Open fn when fn = feature_name -> true
| Int fn when fn = feature_name -> true
| _ -> false
) domain
let rec normalize_domain = function
| [] -> [Int "position"]
| (Int "position") :: tail -> Log.warning "[Domain] declaration of the feature name \"position\" in useless"; normalize_domain tail
| (Open "position") :: _
| (Closed ("position",_)) :: _ ->
Error.build "[Domain] The feature named \"position\" is reserved and must be types 'integer', you cannot not redefine it"
| (Int fn) :: tail | (Open fn) :: tail | Closed (fn,_) :: tail when is_defined fn tail ->
Error.build "[Domain] The feature named \"%s\" is defined several times" fn
| x :: tail -> x :: (normalize_domain tail)
let current = ref None
let reset () = current := None
let init domain =
current := Some (normalize_domain domain)
let build ?loc name unsorted_values =
let values = List.sort Pervasives.compare unsorted_values in
match (name.[0], !current) with
| ('_', _) (* no check on feat_name starting with '_' *)
| (_, None) -> List.map (fun s -> String s) values (* no domain defined *)
| (_, Some dom) ->
let rec loop = function
| [] -> Error.build ?loc "[GRS] Unknown feature name '%s'" name
| ((Open n)::_) when n = name ->
List.map (fun s -> String s) values
| ((Int n)::_) when n = name ->
(try List.map (fun s -> Float (String_.to_float s)) values
with Failure _ -> Error.build ?loc "[GRS] The feature '%s' is of type int" name)
| ((Closed (n,vs))::_) when n = name ->
(match List_.sort_diff values vs with
| [] -> List.map (fun s -> String s) values
| l when List.for_all (fun x -> x.[0] = '_') l -> List.map (fun s -> String s) values
| l -> Error.build ?loc "Unknown feature values '%s' for feature name '%s'"
(List_.to_string (fun x->x) ", " l)
name
)
| _::t -> loop t in
loop dom
let build_one ?loc name value =
match build ?loc name [value] with
| [x] -> x
| _ -> Error.bug ?loc "[Domain.build_one]"
let feature_names () =
match !current with