Attention une mise à jour du serveur va être effectuée le vendredi 16 avril entre 12h et 12h30. Cette mise à jour va générer une interruption du service de quelques minutes.

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