Commit 60acc36a authored by bguillaum's avatar bguillaum
Browse files

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
(* ================================================================================ *)
......
......@@ -4,332 +4,216 @@ open Log
open Grew_utils
open Grew_ast
module Feature = struct
(* feature= (feature_name, disjunction of atomic values). empty list to encode "any value" *)
type t =
| Equal of string * string list
| Different of string * string list
| Param of string * int
(* ==================================================================================================== *)
module Domain = struct
let current = ref None
let get_name = function | Equal (n,_) -> n | Different (n,_) | Param (n,_) -> n
let reset () = current := None
let get_atom = function | Equal (n,[one]) -> Some one | _ -> None
let init ast_domain = current := Some ast_domain
let check ?loc name values = match !current with
| None -> ()
| Some d ->
let rec loop = function
| [] -> Error.build ?loc "[GRS] Unknown feature name '%s'" name
| ((Ast.Open n)::_) when n = name -> ()
| ((Ast.Closed (n,vs))::_) when n = name ->
(match List_.sort_diff values vs with
| [] -> ()
| 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
end
(* ==================================================================================================== *)
module G_feature = struct
type t = string * string
let get_name = fst
let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
(* suppose all feat_names to be different and ordered *)
let rec check ?domain loc name values = match domain with
| None -> ()
| Some [] -> Log.fmessage "[GRS] Unknown feature name '%s' %s" name (Loc.to_string loc)
| Some ((Ast.Open n)::_) when n = name -> ()
| Some ((Ast.Closed (n,vs))::_) when n = name ->
(match List_.sort_diff values vs with
| [] -> ()
| l -> Error.build ~loc "Unknown feature values '%s' for feature name '%s'"
(List_.to_string (fun x->x) ", " l)
name
)
| Some (_::t) -> check ~domain:t loc name values
let build ?pat_vars ?domain = function
| ({Ast.kind=Ast.Equality unsorted_values ;name=name},loc) ->
let build = function
| ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
Domain.check ~loc name [atom];
(name, atom)
| _ -> Error.build "Illegal feature declaration in Graph (must be '=' and atomic)"
let to_string (feat_name, value) = sprintf "%s=\"%s\"" feat_name value
let to_dep (feat_name, value) = sprintf "%s=%s" feat_name value
end
(* ==================================================================================================== *)
module P_feature = struct
(* feature= (feature_name, disjunction of atomic values) *)
type v =
| Equal of string list (* with Equal constr, the list is MUST never be empty *)
| Different of string list
| Param of int
type t = string * v
let get_name = fst
let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
let to_string = function
| (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string (fun x->x) "|" 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, Param index) -> sprintf "%s=$%d" feat_name index
let build ?pat_vars = function
| ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
let values = List.sort Pervasives.compare unsorted_values in
check ?domain loc name values;
Equal (name, values)
| ({Ast.kind=Ast.Disequality unsorted_values;name=name},loc) ->
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
check ?domain loc name values;
Different (name, values)
| ({Ast.kind=Ast.Param var; name=name},loc) ->
Domain.check ~loc name values;
(name, Different values)
| ({Ast.kind=Ast.Param var; name=name}, loc) ->
match pat_vars with
| None -> Error.build "Unknown pattern variable '%s'" var
| None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
| Some l ->
match List_.pos var l with
| Some index -> Param (name, index)
| None -> Error.build "Unknown pattern variable '%s'" var
| Some index -> (name, Param index)
| None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
end
module Feature_structure = struct
(* ==================================================================================================== *)
module G_fs = struct
(* list are supposed to be striclty ordered wrt compare*)
type t = Feature.t list
type t = G_feature.t list
let build ?pat_vars ?domain ast_fs =
let unsorted = List.map (Feature.build ?pat_vars ?domain) ast_fs in
List.sort Feature.compare unsorted
let empty = []
let of_conll line =
let morph_fs =
List.map (fun (feat_name, feat_value) -> Feature.Equal (feat_name, [feat_value])) line.Conll.morph in
let unsorted =
Feature.Equal ("phon", [line.Conll.phon]) ::
Feature.Equal ("lemma", [line.Conll.lemma]) ::
Feature.Equal ("cat", [line.Conll.pos2]) ::
morph_fs in
List.sort Feature.compare unsorted
let set_feat ?loc feature_name atom t =
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
| (fn,a)::t -> (fn,a) :: (loop t)
in loop t
let del_feat = List_.sort_remove_assoc
let empty = []
let get_atom = List_.sort_assoc
let to_gr t = List_.to_string G_feature.to_string ", " t
let rec get name = function
| [] -> None
| Feature.Equal (n,l) :: _ when n=name -> Some l
| Feature.Equal (n,l) :: t when n<name -> get name t
| Feature.Equal _ :: _ -> None
| Feature.Different _ :: _ -> Log.critical "[Feature_structure.get] this fs contains 'Different' constructor"
| Feature.Param _ :: _ -> Log.critical "[Feature_structure.get] this fs contains 'Param' constructor"
let get_atom name t =
match get name t with
| Some [one] -> Some one
| _ -> None
let string_of_feature = function
| Feature.Equal (feat_name, atoms) ->
sprintf "%s=%s" feat_name
(match atoms with
| [] -> "*"
| h::t -> List.fold_right (fun atom acc -> atom^"|"^acc) t h
)
| Feature.Different (feat_name, atoms) ->
sprintf "%s<>%s" feat_name
(match atoms with
| [] -> "EMPTY"
| h::t -> List.fold_right (fun atom acc -> atom^"|"^acc) t h
)
| Feature.Param (feat_name, index) ->
sprintf "@%d" index
let to_string t = List_.to_string string_of_feature "\\n" t
let to_string t = List_.to_string G_feature.to_string "\\n" t
let build ast_fs =
let unsorted = List.map (fun feat -> G_feature.build feat) ast_fs in
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
List.sort G_feature.compare unsorted
exception Fail_unif
let unif fs1 fs2 =
let rec loop = function
| [], fs | fs, [] -> fs
| (f1::t1, f2::t2) when G_feature.compare f1 f2 < 0 -> f1 :: loop (t1, f2::t2)
| (f1::t1, f2::t2) when G_feature.compare f1 f2 > 0 -> f2 :: loop (f1::t1, t2)
(* all remaining case are fn1 = fn2 *)
| ((fn, a1)::t1, (_, a2)::t2) when a1=a2 -> (fn,a1) :: (loop (t1, t2))
| _ -> raise Fail_unif
in try Some (loop (fs1, fs2)) with Fail_unif -> None
let get_main ?main_feat t =
let main_list = match main_feat with
| None -> []
| Some string -> Str.split (Str.regexp " *; *") string in
let rec loop = function
| [] -> (None, t)
| feat_name :: tail ->
(match List.partition (fun f -> Feature.get_name f = feat_name) t with
| ([], _) -> loop tail
| ([one], sub) -> (Some one, sub)
| _ -> Log.critical "[Feature_structure.to_dep] several feature with the same name") in
match List_.sort_assoc feat_name t with
| Some atom -> (Some atom, List_.sort_remove_assoc feat_name t)
| None -> loop tail in
loop main_list
let escape string =
Str.global_replace (Str.regexp_string "//PV//") ";"
(Str.global_replace (Str.regexp_string "//AND//") "&amp;" string)
let to_dot ?main_feat t =
let (main_opt, sub) = get_main ?main_feat t in
sprintf "%s%s"
(match main_opt with
| Some feat -> escape (match Feature.get_atom feat with Some atom -> atom^"|" | None -> "")
| None -> "" )
(List_.to_string string_of_feature "\\n" sub)
let gr_of_feature = function
| Feature.Equal (feat_name, [one]) -> sprintf "%s=\"%s\"" feat_name one
| _ -> Log.critical "[Feature_structure.gr_of_feature] all feature in gr must be atomic value"
let to_gr t = List_.to_string gr_of_feature ", " t
let to_dot ?main_feat t =
match get_main ?main_feat t with
| (None, _) -> List_.to_string G_feature.to_string "\\n" t
| (Some atom, sub) -> sprintf "%s|%s" atom (List_.to_string G_feature.to_string "\\n" sub)
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 feat -> escape (match Feature.get_atom feat with Some atom -> atom | None -> "")
| None -> "")
(escape (List_.to_string string_of_feature "#" sub))
let rec set_feat feature_name atoms = function
| [] -> [Feature.Equal (feature_name, atoms)]
| ((Feature.Equal (fn,_))::_) as t when feature_name < fn -> (Feature.Equal (feature_name, atoms))::t
| (Feature.Equal (fn,_))::t when feature_name = fn -> (Feature.Equal (feature_name, atoms))::t
| Feature.Equal (fn,ats)::t -> Feature.Equal (fn,ats):: (set_feat feature_name atoms t)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
let rec del_feat feature_name = function
| [] -> []
| ((Feature.Equal (fn,_))::_) as t when feature_name < fn -> t
| (Feature.Equal (fn,_))::t when feature_name = fn -> t
| Feature.Equal (fn,ats)::t -> Feature.Equal (fn,ats):: (del_feat feature_name t)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
let compatible pattern fs =
let rec loop = function
| [], _ -> true
(* Three next cases: each feature_name present in pattern must be in instance *)
| _, [] -> false
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> false
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> false
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop ((Feature.Equal (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop ((Feature.Different (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn *) ->
(match fv_pat, fv with
| [],_ | _, [] -> loop (t_pat,t)
| l_pat,l -> not (List_.sort_disjoint l_pat l) && loop (t_pat,t)
)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv_pat, fv with
| [],_ | _, [] -> loop (t_pat,t) (* FIXME should be "false" *)
| l_pat,l -> (List_.sort_disjoint l_pat l) && loop (t_pat,t)
)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
in loop (pattern,fs)
let compatible_param param pattern fs =
let rec loop acc_param = function
| [], _ -> acc_param
(* Three next cases: each feature_name present in pattern must be in instance: [] means unif failure *)
| _, [] -> []
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> []
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> []
(* Two next cases: a feature in graph, not in pattern *)
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Equal (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Different (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Param (fn_pat, i))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Param (fn_pat, i))::t_pat, t)
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn *) ->
(match fv_pat, fv with
| [],_ -> (* pattern_value is ? *) loop acc_param (t_pat,t)
| l_pat,l when not (List_.sort_disjoint l_pat l) -> loop acc_param (t_pat,t)
| _ -> (* l_pat and l disjoint -> no sol *) []
)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv_pat, fv with
| [],_ -> []
| l_pat,l when List_.sort_disjoint l_pat l -> loop acc_param (t_pat,t)
| _ -> (* l_pat and l disjoint -> no disjoint *) []
)
| ((Feature.Param (fn_pat, i))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv with
| [atom] ->
let reduce_param = List.filter (fun (x,_) -> List.nth x i = atom) acc_param in
loop reduce_param (t_pat,t)
| _ -> Log.critical "[compatible_param] Graph feature value not atomic"
)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
in loop param (pattern,fs)
exception Fail_unif
exception Bug_unif of string
let unif fs1 fs2 =
let rec loop = function
| [], fs
| fs, [] -> fs
| (f1::t1, f2::t2) when Feature.compare f1 f2 < 0 -> f1 :: loop (t1, f2::t2)
| (f1::t1, f2::t2) when Feature.compare f1 f2 > 0 -> f2 :: loop (f1::t1, t2)
(match main_opt with Some atom -> atom | None -> "")
(List_.to_string G_feature.to_dep "#" sub)
end
(* ==================================================================================================== *)
module P_fs = struct
(* list are supposed to be striclty ordered wrt compare*)
type t = P_feature.t list
(* all remaining case are fn1 = fn2 *)
| ((Feature.Equal (fn, fv1))::t1, (Feature.Equal (_, fv2))::t2) ->
(match List_.sort_inter fv1 fv2 with
| [] -> raise Fail_unif
| fv -> (Feature.Equal (fn, fv)) :: (loop (t1, t2)))
| ((Feature.Different (fn, fv1))::t1, (Feature.Equal (_, fv2))::t2) ->
(match List_.sort_diff fv2 fv1 with
| [] -> raise Fail_unif
| fv -> (Feature.Equal (fn, fv)) :: (loop (t1, t2)))
| ((Feature.Equal (fn, fv1))::t1, (Feature.Different (_, fv2))::t2) ->
(match List_.sort_diff fv1 fv2 with
| [] -> raise Fail_unif
| fv -> (Feature.Equal (fn, fv)) :: (loop (t1, t2)))
| _ -> raise (Bug_unif "two value declared \"Feature.Different\", cannot reply without the domain !")
in try Some (loop (fs1, fs2)) with Fail_unif -> None
let empty = []
let build ?pat_vars ast_fs =
let unsorted = List.map (P_feature.build ?pat_vars) ast_fs in
List.sort P_feature.compare unsorted
let to_string t = List_.to_string P_feature.to_string "\\n" t
let to_dot t = List_.to_string P_feature.to_string "\\n" t
let unifiable fs1 fs2 =
let rec loop = function
| [], fs
| fs, [] -> true
exception Fail
| (f1::t1, f2::t2) when Feature.compare f1 f2 < 0 -> loop (t1, f2::t2)
| (f1::t1, f2::t2) when Feature.compare f1 f2 > 0 -> loop (f1::t1, t2)
let match_ ?param pattern fs =
let rec loop acc = function
| [], _ -> acc
(* all remaining case are fn1 = fn2 *)
| ((Feature.Equal (fn, fv1))::t1, (Feature.Equal (_, fv2))::t2) ->
(match List_.sort_inter fv1 fv2 with
| [] -> false
| _ -> loop (t1, t2))
(* Two next cases: each feature_name present in pattern must be in instance: [] means unif failure *)
| _, [] -> raise Fail
| ((fn_pat, _)::_, (fn, _)::_) when fn_pat < fn -> raise Fail
| ((Feature.Different (fn, fv1))::t1, (Feature.Equal (_, fv2))::t2) ->
(match List_.sort_diff fv2 fv1 with
| [] -> false
| _ -> loop (t1, t2))
(* a feature_name present only in instance -> Skip it *)
| ((fn_pat, fv_pat)::t_pat, (fn, _)::t) when fn_pat > fn -> loop acc ((fn_pat, fv_pat)::t_pat, t)
| ((Feature.Equal (fn, fv1))::t1, (Feature.Different (_, fv2))::t2) ->
(match List_.sort_diff fv1 fv2 with
| [] -> false
| _ -> loop (t1, t2))
| _ -> raise (Bug_unif "two value declared \"Different\", cannot reply without the domain !")
in loop (fs1, fs2)
(* Next cases: fn_pat = fn *)
| ((_, (P_feature.Equal fv))::t_pat, (_, fa)::t) when List_.sort_mem fa fv -> loop acc (t_pat,t)
| ((_, (P_feature.Different fv))::t_pat, (_, fa)::t) when not (List_.sort_mem fa fv) -> loop acc (t_pat,t)
| ((_, (P_feature.Param index))::t_pat, (_, atom)::t) ->
(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
| None -> None
| Some new_param -> loop (Some new_param) (t_pat,t)
)
)
(* remaining cases: Equal and not list_mem | Diff and not list_mem -> fail*)
| _ -> raise Fail
in loop param (pattern,fs)
let filter fs_p fs_g =
let rec loop = function
| [], fs -> true
| fs, [] -> false
| (f1::t1, f2::t2) when Feature.compare f1 f2 < 0 -> false
| (f1::t1, f2::t2) when Feature.compare f1 f2 > 0 -> loop (f1::t1, t2)
| ((fn1,_)::_, (fn2,_)::_) when fn1 < fn2 -> false
| ((fn1,_)::_ as f1, (fn2,_)::t2) when fn1 > fn2 -> loop (f1, t2)
(* all remaining case are fn1 = fn2 *)
| ((Feature.Equal (fn, fv1))::t1, (Feature.Equal (_, fv2))::t2) ->
(match List_.sort_inter fv1 fv2 with
| [] -> false
| _ -> loop (t1, t2))
| ((Feature.Different (fn, fv1))::t1, (Feature.Equal (_, fv2))::t2) ->
(match List_.sort_diff fv2 fv1 with
| [] -> false
| _ -> loop (t1, t2))
| ((Feature.Equal (fn, fv1))::t1, (Feature.Different (_, fv2))::t2) ->
(match List_.sort_diff fv1 fv2 with
| [] -> false
| _ -> loop (t1, t2))
| _ -> raise (Bug_unif "two value declared \"Different\", cannot reply without the domain !")
in loop (fs_p, fs_g)
| ((_, (P_feature.Equal fv))::t1, (_, atom)::t2) when List_.sort_mem atom fv -> loop (t1, t2)
| ((_, (P_feature.Different fv))::t1, (_, atom)::t2) when not (List_.sort_mem atom fv) -> loop (t1, t2)
| _ -> false
in loop (fs_p, fs_g)
end