Commit c66b444e authored by bguillaum's avatar bguillaum

add features with int values

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7570 7838e531-6607-4d57-9587-6c381814729c
parent 20c919bb
......@@ -7,6 +7,7 @@ module Ast = struct
type feature_spec =
| Closed of string * string list (* (the name, the set of atomic values) *)
| Open of string (* the name *)
| Int of string (* the name *)
type domain = feature_spec list
......
......@@ -4,7 +4,8 @@ module Ast : sig
type feature_spec =
| Closed of string * string list (* (the name, the set of atomic values) *)
| Open of string (* the name *)
| Int of string (* the name *)
type domain = feature_spec list
type feature_kind =
......
......@@ -4,6 +4,13 @@ open Log
open Grew_utils
open Grew_ast
type value = String of string | Int of int
let string_of_value = function
| String s -> s
| Int i -> string_of_int i
(* ==================================================================================================== *)
module Domain = struct
let current = ref None
......@@ -31,30 +38,65 @@ module Domain = struct
)
| _::t -> loop t in
loop d
let build ?loc name values =
match (name.[0], !current) with
| ('_', _)
| (_, None) -> List.map (fun s -> String s) values (* no check on feat_name starting with '_' *)
| (_, Some d) ->
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 -> Int (int_of_string 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 -> Error.build ?loc "Unknown feature values '%s' for feature name '%s'"
(List_.to_string (fun x->x) ", " l)
name
)
| _::t -> loop t in
loop d
let build_one ?loc name value =
match build ?loc name [value] with
| [x] -> x
| _ -> Error.bug ?loc "[Domain.build_one]"
end
(* ==================================================================================================== *)
module G_feature = struct
type t = string * string
type t = string * value
let get_name = fst
let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
let build = function
let build (x : Ast.feature) = match x with
| ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
Domain.check ~loc name [atom];
(name, atom)
(* Domain.check ~loc name [atom]; *)
(* (name, atom) *)
(name, Domain.build_one ~loc name atom)
| _ -> Error.build "Illegal feature declaration in Graph (must be '=' and atomic)"
let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name feat_val
let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name (string_of_value feat_val)
let to_gr (feat_name, feat_val) = sprintf "%s=\"%s\"" feat_name feat_val
let to_gr (feat_name, feat_val) =
match feat_val with
| String s -> sprintf "%s=\"%s\"" feat_name s
| Int i -> sprintf "%s=\"%d\"" feat_name i
let to_dot (feat_name, feat_val) =
match Str.split (Str.regexp ":C:") feat_val with
| [] -> Error.bug "[G_feature.to_dot] feature value '%s'" feat_val
| fv::_ -> sprintf "%s=%s" feat_name fv
match feat_val with
| Int i -> sprintf "%s=%d" feat_name i
| String s ->
match Str.split (Str.regexp ":C:") s with
| [] -> Error.bug "[G_feature.to_dot] feature value '%s'" s
| fv::_ -> sprintf "%s=%s" feat_name fv
end
(* ==================================================================================================== *)
......@@ -62,8 +104,8 @@ module P_feature = struct
(* feature= (feature_name, disjunction of atomic values) *)
type v =
| Equal of string list (* with Equal constr, the list MUST never be empty *)
| Different of string list
| Equal of value list (* with Equal constr, the list MUST never be empty *)
| Different of value list
| Param of int
type t = string * v
......@@ -82,9 +124,9 @@ module P_feature = struct
| _ -> Error.build "cannot unify heterogeneous pattern features"
let to_string ?param_names = function
| (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string (fun x->x) "|" atoms)
| (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, Different []) -> sprintf "%s=*" feat_name
| (feat_name, Different atoms) -> sprintf "%s<>%s" feat_name (List_.to_string (fun x->x) "|" atoms)
| (feat_name, Different atoms) -> sprintf "%s<>%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, Param index) ->
match param_names with
| None -> sprintf "%s=$%d" feat_name index
......@@ -92,13 +134,15 @@ module P_feature = struct
let build ?pat_vars = function
| ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
let values = List.sort Pervasives.compare unsorted_values in
Domain.check ~loc name values;
(name, Equal values)
let values = Domain.build ~loc name unsorted_values in (name, Equal values)
(* let values = List.sort Pervasives.compare unsorted_values in *)
(* Domain.check ~loc name values; *)
(* (name, Equal values) *)
| ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
let values = List.sort Pervasives.compare unsorted_values in
Domain.check ~loc name values;
(name, Different values)
let values = Domain.build ~loc name unsorted_values in (name, Different values)
(* let values = List.sort Pervasives.compare unsorted_values in *)
(* Domain.check ~loc name values; *)
(* (name, Different values) *)
| ({Ast.kind=Ast.Param var; name=name}, loc) ->
match pat_vars with
| None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
......@@ -113,16 +157,17 @@ module G_fs = struct
(* list are supposed to be striclty ordered wrt compare*)
type t = G_feature.t list
let to_raw t = t
let to_raw t = List.map (fun (name, value) -> (name, string_of_value value)) t
let empty = []
let set_feat ?loc feature_name atom t =
Domain.check ?loc feature_name [atom];
let new_value = Domain.build_one ?loc feature_name atom in
(* Domain.check ?loc feature_name [atom]; *)
let rec loop = function
| [] -> [(feature_name, atom)]
| ((fn,_)::_) as t when feature_name < fn -> (feature_name, atom)::t
| (fn,_)::t when feature_name = fn -> (feature_name, atom)::t
| [] -> [(feature_name, new_value)]
| ((fn,_)::_) as t when feature_name < fn -> (feature_name, new_value)::t
| (fn,_)::t when feature_name = fn -> (feature_name, new_value)::t
| (fn,a)::t -> (fn,a) :: (loop t)
in loop t
......@@ -130,6 +175,11 @@ module G_fs = struct
let get_atom = List_.sort_assoc
let get_string_atom feat_name t =
match List_.sort_assoc feat_name t with
| None -> None
| Some v -> Some (string_of_value v)
let to_string t = List_.to_string G_feature.to_string "," t
let to_gr t = List_.to_string G_feature.to_gr ", " t
......@@ -138,7 +188,11 @@ module G_fs = struct
List.sort G_feature.compare unsorted
let of_conll line =
let unsorted = ("phon", line.Conll.phon) :: ("lemma", line.Conll.lemma) :: ("cat", line.Conll.pos2) :: line.Conll.morph in
let unsorted =
("phon", String line.Conll.phon)
:: ("lemma", String line.Conll.lemma)
:: ("cat", String line.Conll.pos2)
:: (List.map (fun (f,v) -> (f, String v)) line.Conll.morph) in
List.sort G_feature.compare unsorted
exception Fail_unif
......@@ -169,19 +223,20 @@ module G_fs = struct
let to_dot ?main_feat t =
match get_main ?main_feat t with
| (None, _) -> List_.to_string G_feature.to_dot "\\n" t
| (Some atom, sub) -> sprintf "{%s|%s}" atom (List_.to_string G_feature.to_dot "\\n" sub)
| (Some atom, sub) ->
sprintf "{%s|%s}" (string_of_value atom) (List_.to_string G_feature.to_dot "\\n" sub)
let to_word ?main_feat t =
match get_main ?main_feat t with
| (None, _) -> "#"
| (Some atom, _) -> atom
| (Some atom, _) -> string_of_value atom
let to_dep ?main_feat t =
let (main_opt, sub) = get_main ?main_feat t in
sprintf " word=\"%s\"; subword=\"%s\"; "
(match main_opt with Some atom -> atom | None -> "")
(match main_opt with Some atom -> string_of_value atom | None -> "")
(List_.to_string G_feature.to_string "#" sub)
end
end (* module G_fs *)
(* ==================================================================================================== *)
module P_fs = struct
......@@ -221,7 +276,7 @@ module P_fs = struct
(match acc with
| None -> Log.bug "[P_fs.compatible] Illegal parametrized pattern feature"; exit 2
| Some param ->
(match Lex_par.filter index atom param with
(match Lex_par.filter index (string_of_value atom) param with
| None -> raise Fail
| Some new_param -> loop (Some new_param) (t_pat,t)
)
......
......@@ -21,9 +21,9 @@ module G_fs: sig
If [t] does not contain such a feature, [t] is returned unchanged. *)
val del_feat: string -> t -> t
(** [get_atom f t] returns [Some v] if the fs [t] contains the feature (f,v).
(** [get_string_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 get_string_atom: string -> t -> string option
val to_gr: t -> string
val to_dot: ?main_feat: string -> t -> string
......
......@@ -481,7 +481,7 @@ module G_graph = struct
(function
| Concat_item.Feat (node_gid, feat_name) ->
let node = Gid_map.find node_gid graph.map in
(match G_fs.get_atom feat_name (G_node.get_fs node) with
(match G_fs.get_string_atom feat_name (G_node.get_fs node) with
| Some atom -> atom
| None -> Error.run ?loc "Some feature (named \"%s\") is not defined" feat_name
)
......
......@@ -333,8 +333,9 @@ module Html_doc = struct
wnl " <code class=\"code\">";
List.iter
(function
| Ast.Open feat_name -> wnl " <b>%s</b> : *<br/>" feat_name
| Ast.Closed (feat_name,values) -> wnl "<b>%s</b> : %s<br/>" feat_name (String.concat " | " values)
| Ast.Open feat_name -> wnl " <b>%s</b> : *<br/>" feat_name
| Ast.Int feat_name -> wnl " <b>%s</b> : #<br/>" feat_name
) ast.Ast.domain;
wnl " </code>";
......
......@@ -383,8 +383,8 @@ module Rule = struct
| Feature_eq (pid1, feat_name1, pid2, feat_name2) ->
let gnode1 = G_graph.find (Pid_map.find pid1 matching.n_match) graph in
let gnode2 = G_graph.find (Pid_map.find pid2 matching.n_match) graph in
(match (G_fs.get_atom feat_name1 (G_node.get_fs gnode1),
G_fs.get_atom feat_name2 (G_node.get_fs gnode2)
(match (G_fs.get_string_atom feat_name1 (G_node.get_fs gnode1),
G_fs.get_string_atom feat_name2 (G_node.get_fs gnode2)
) with
| Some fv1, Some fv2 when fv1 = fv2 -> true
| _ -> false)
......
......@@ -28,6 +28,7 @@ let localize t = (t,get_loc ())
%token COMA /* , */
%token SEMIC /* ; */
%token STAR /* * */
%token SHARP /* # */
%token PLUS /* + */
%token EQUAL /* = */
%token DISEQUAL /* <> */
......@@ -198,10 +199,11 @@ features_group:
%inline feature:
| name = feature_name DDOT values = features_values
{
if values = ["*"]
then Ast.Open name
else Ast.Closed (name, List.sort Pervasives.compare values)
{
match values with
| ["*"] -> Ast.Open name
| ["#"] -> Ast.Int name
| _ -> Ast.Closed (name, List.sort Pervasives.compare values)
}
feature_name:
......@@ -209,6 +211,7 @@ feature_name:
features_values:
| STAR { ["*"] }
| SHARP { ["#"] }
| x = separated_nonempty_list(COMA,value) { x }
......
......@@ -117,6 +117,7 @@ and global = parse
| ',' { COMA }
| '+' { PLUS }
| '*' { STAR }
| '#' { SHARP }
| '=' { EQUAL }
| "<>" { DISEQUAL }
| '|' { PIPE }
......
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