Commit f09d5e0d authored by bguillaum's avatar bguillaum

The domain is encoded in GRS and is not anymore a global variable

WARNING: breaks libgrew.mli

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8832 7838e531-6607-4d57-9587-6c381814729c
parent 8bc94f59
......@@ -267,14 +267,14 @@ module Ast = struct
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: Domain.t;
domain_wi: Domain.feature_spec list;
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.t;
domain: Domain.feature_spec list;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
......
......@@ -182,7 +182,7 @@ module Ast : sig
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: Domain.t;
domain_wi: Domain.feature_spec list;
labels_wi: (string * string list) list; (* the list of global edge labels *)
modules_wi: module_or_include list;
sequences_wi: sequence list;
......@@ -190,7 +190,7 @@ module Ast : sig
(* a GRS: graph rewriting system *)
type grs = {
domain: Domain.t;
domain: Domain.feature_spec list;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
......
......@@ -65,7 +65,7 @@ module Command = struct
| H_MERGE_NODE of (Gid.t * Gid.t)
| H_ACT_NODE of (Gid.t * string)
let build ?param (kai, kei) table locals suffixes ast_command =
let build domain ?param (kai, kei) table locals suffixes ast_command =
(* kai stands for "known act ident", kei for "known edge ident" *)
let pid_of_act_id loc = function
......@@ -169,7 +169,7 @@ module Command = struct
if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
check_act_id loc act_id kai;
Domain.check_feature_name ~loc feat_name;
Domain.check_feature_name ~loc domain feat_name;
((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
| (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
......@@ -178,7 +178,7 @@ module Command = struct
(function
| Ast.Qfn_item (node_id,feature_name) ->
check_node_id loc node_id kai;
Domain.check_feature_name ~loc feature_name;
Domain.check_feature_name ~loc domain feature_name;
Feat (pid_of_node_id loc node_id, feature_name)
| Ast.String_item s -> String s
| Ast.Param_item var ->
......@@ -192,9 +192,9 @@ module Command = struct
) ast_items in
(* check for consistency *)
(match items with
| _ when Domain.is_open feat_name -> ()
| _ when Domain.is_open domain feat_name -> ()
| [Param_out _] -> () (* TODO: check that lexical parameters are compatible with the feature domain *)
| [String s] -> Domain.check_feature ~loc feat_name s
| [String s] -> Domain.check_feature ~loc domain feat_name s
| [Feat (_,fn)] -> ()
| _ -> Error.build ~loc "[Update_feat] Only open features can be modified with the concat operator '+' but \"%s\" is not declared as an open feature" feat_name);
((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei))
......
......@@ -58,6 +58,7 @@ module Command : sig
| H_ACT_NODE of (Gid.t * string)
val build:
Domain.t ->
?param: (string list * string list) ->
(Ast.command_node_ident list * string list) ->
Id.table ->
......
......@@ -33,9 +33,9 @@ module G_feature = struct
| (None, Some j) -> 1
| (None, None) -> Pervasives.compare name1 name2
let build (x : Ast.feature) = match x with
let build domain = function
| ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
(name, Domain.build_one ~loc name atom)
(name, Domain.build_value ~loc domain 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 (string_of_value feat_val)
......@@ -130,14 +130,14 @@ module P_feature = struct
| _ -> Error.bug "[P_feature.to_string] multiple parameters are not handled"
let build ?pat_vars = function
let build domain ?pat_vars = function
| ({Ast.kind=Ast.Absent; name=name}, loc) ->
Domain.check_feature_name ~loc name;
Domain.check_feature_name ~loc domain name;
(name, {cst=Absent;in_param=[];})
| ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
let values = Domain.build ~loc name unsorted_values in (name, {cst=Equal values;in_param=[];})
let values = Domain.build_disj ~loc domain name unsorted_values in (name, {cst=Equal values;in_param=[];})
| ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
let values = Domain.build ~loc name unsorted_values in (name, {cst=Different values;in_param=[];})
let values = Domain.build_disj ~loc domain name unsorted_values in (name, {cst=Different values;in_param=[];})
| ({Ast.kind=Ast.Equal_param var; name=name}, loc) ->
begin
match pat_vars with
......@@ -161,8 +161,8 @@ module G_fs = struct
let empty = []
(* ---------------------------------------------------------------------- *)
let set_feat ?loc feature_name atom t =
let new_value = Domain.build_one ?loc feature_name atom in
let set_feat ?loc domain feature_name atom t =
let new_value = Domain.build_value ?loc domain feature_name atom in
let rec loop = function
| [] -> [(feature_name, new_value)]
| ((fn,_)::_) as t when feature_name < fn -> (feature_name, new_value)::t
......@@ -203,22 +203,22 @@ module G_fs = struct
let to_gr t = List_.to_string G_feature.to_gr ", " t
(* ---------------------------------------------------------------------- *)
let build ast_fs =
let unsorted = List.map (fun feat -> G_feature.build feat) ast_fs in
let build domain ast_fs =
let unsorted = List.map (fun feat -> G_feature.build domain feat) ast_fs in
List.sort G_feature.compare unsorted
(* ---------------------------------------------------------------------- *)
let of_conll ?loc line =
let of_conll ?loc domain line =
let raw_list0 =
("phon", Domain.build_one ?loc "phon" line.Conll.phon)
:: ("cat", Domain.build_one ?loc "cat" line.Conll.pos1)
:: (List.map (fun (f,v) -> (f, Domain.build_one ?loc f v)) line.Conll.morph) in
("phon", Domain.build_value ?loc domain "phon" line.Conll.phon)
:: ("cat", Domain.build_value ?loc domain "cat" line.Conll.pos1)
:: (List.map (fun (f,v) -> (f, Domain.build_value ?loc domain f v)) line.Conll.morph) in
let raw_list1 = match line.Conll.pos2 with
| "" | "_" -> raw_list0
| s -> ("pos", Domain.build_one ?loc "pos" s) :: raw_list0 in
| s -> ("pos", Domain.build_value ?loc domain "pos" s) :: raw_list0 in
let raw_list2 = match line.Conll.lemma with
| "" | "_" -> raw_list1
| s -> ("lemma", Domain.build_one ?loc "lemma" s) :: raw_list1 in
| s -> ("lemma", Domain.build_value ?loc domain "lemma" s) :: raw_list1 in
List.sort G_feature.compare raw_list2
(* ---------------------------------------------------------------------- *)
......@@ -347,8 +347,8 @@ module P_fs = struct
| _ -> Error.bug "Position can't be parametrized"
with Not_found -> true
let build ?pat_vars ast_fs =
let unsorted = List.map (P_feature.build ?pat_vars) ast_fs in
let build domain ?pat_vars ast_fs =
let unsorted = List.map (P_feature.build domain ?pat_vars) ast_fs in
List.sort P_feature.compare unsorted
let feat_list t = List.map P_feature.get_name t
......
......@@ -19,9 +19,9 @@ module G_fs: sig
val empty: t
(** [set_feat feature_name atom t] adds the feature ([feature_name],[atom]) in [t].
(** [set_feat domain 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
val set_feat: ?loc:Loc.t -> Domain.t -> feature_name -> 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. *)
......@@ -46,9 +46,9 @@ module G_fs: sig
val to_string: t -> string
val build: Ast.feature list -> t
val build: Domain.t -> Ast.feature list -> t
val of_conll: ?loc:Loc.t -> Conll.line -> t
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.line -> 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. *)
......@@ -62,7 +62,7 @@ module P_fs: sig
val empty: t
val build: ?pat_vars: string list -> Ast.feature list -> t
val build: Domain.t -> ?pat_vars: string list -> Ast.feature list -> t
val to_string: t -> string
......
......@@ -47,21 +47,21 @@ module P_graph = struct
| Some new_node -> Some (Pid_map.add id_src new_node map)
(* -------------------------------------------------------------------------------- *)
let build_filter table (ast_node, loc) =
let build_filter domain table (ast_node, loc) =
let pid = Id.build ~loc ast_node.Ast.node_id table in
let fs = P_fs.build ast_node.Ast.fs in
let fs = P_fs.build domain ast_node.Ast.fs in
(pid, fs)
(* -------------------------------------------------------------------------------- *)
let build ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
let build domain ?pat_vars ?(locals=[||]) (full_node_list : Ast.node list) full_edge_list =
(* NB: insert searches for a previous node with the Same name and uses unification rather than constraint *)
(* NB: insertion of new node at the end of the list: not efficient but graph building is not the hard part. *)
let rec insert (ast_node, loc) = function
| [] -> [P_node.build ?pat_vars (ast_node, loc)]
| [] -> [P_node.build domain ?pat_vars (ast_node, loc)]
| (node_id,fs)::tail when ast_node.Ast.node_id = node_id ->
begin
try (node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
try (node_id, P_node.unif_fs (P_fs.build domain ?pat_vars ast_node.Ast.fs) fs) :: tail
with Error.Build (msg,_) -> raise (Error.Build (msg,Some loc))
end
| head :: tail -> head :: (insert (ast_node, loc) tail) in
......@@ -108,9 +108,9 @@ module P_graph = struct
(* -------------------------------------------------------------------------------- *)
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_extension ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let build_extension domain ?pat_vars ?(locals=[||]) pos_table full_node_list full_edge_list =
let built_nodes = List.map (P_node.build ?pat_vars) full_node_list in
let built_nodes = List.map (P_node.build domain ?pat_vars) full_node_list in
let (old_nodes, new_nodes) =
List.partition
......@@ -295,7 +295,7 @@ module G_graph = struct
| None -> None
(* -------------------------------------------------------------------------------- *)
let build ?(locals=[||]) gr_ast =
let build domain ?(locals=[||]) gr_ast =
let full_node_list = gr_ast.Ast.nodes
and full_edge_list = gr_ast.Ast.edges in
......@@ -309,7 +309,7 @@ module G_graph = struct
if List.mem node_id already_bound
then Error.build "[GRS] [Graph.build] try to build a graph with twice the same node id '%s'" node_id
else
let (new_id,new_node) = G_node.build ~def_position:!next_free_position (ast_node, loc) in
let (new_id,new_node) = G_node.build domain ~def_position:!next_free_position (ast_node, loc) in
next_free_position := 1. +. (max !next_free_position (G_node.get_position new_node));
let new_tail = loop (node_id :: already_bound) tail in
(new_id,new_node) :: new_tail in
......@@ -343,7 +343,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
let of_conll ?loc (meta, lines, range_lines) =
let of_conll ?loc domain (meta, lines, range_lines) =
let sorted_lines = Conll.root :: (List.sort Conll.compare lines) in
let gtable = (Array.of_list (List.map (fun line -> line.Conll.num) sorted_lines), string_of_int) in
......@@ -352,7 +352,7 @@ module G_graph = struct
List_.foldi_left
(fun i acc line ->
let loc = Loc.opt_set_line i loc in
Gid_map.add (Gid.Old i) (G_node.of_conll ?loc line) acc)
Gid_map.add (Gid.Old i) (G_node.of_conll domain ?loc line) acc)
Gid_map.empty sorted_lines in
let map_with_edges =
List.fold_left
......@@ -386,7 +386,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
(** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/." *)
let of_brown ?sentid brown =
let of_brown domain ?sentid brown =
let units = Str.split (Str.regexp " ") brown in
let conll_lines = List.mapi
(fun i item -> match Str.full_split (Str.regexp "/[A-Z'+'']+/") item with
......@@ -407,7 +407,7 @@ module G_graph = struct
}
| _ -> Error.build "[Graph.of_brown] Cannot parse Brown item >>>%s<<< (expected \"phon/POS/lemma\")" item
) units in
of_conll ([], conll_lines, [])
of_conll domain ([], conll_lines, [])
(* -------------------------------------------------------------------------------- *)
let opt_att atts name =
......@@ -416,7 +416,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
(** [of_xml d_xml] loads a graph in the xml format: [d_xml] must be a <D> xml element *)
let of_xml d_xml =
let of_xml domain d_xml =
match d_xml with
| Xml.Element ("D", _, t_or_r_list) ->
let (t_list, r_list) = List.partition (function Xml.Element ("T",_,_) -> true | _ -> false) t_or_r_list in
......@@ -429,7 +429,7 @@ module G_graph = struct
let other_feats = List.filter (fun (n,_) -> not (List.mem n ["id"; "start"; "end"; "label"])) t_atts in
let new_fs =
List.fold_left
(fun acc2 (fn,fv) -> G_fs.set_feat fn fv acc2)
(fun acc2 (fn,fv) -> G_fs.set_feat domain fn fv acc2)
G_fs.empty
(("phon", phon) :: ("cat", (List.assoc "label" t_atts)) :: other_feats) in
let new_node = G_node.set_fs new_fs (G_node.set_position (float i) G_node.empty) in
......@@ -614,18 +614,18 @@ module G_graph = struct
| None -> None
(* -------------------------------------------------------------------------------- *)
let set_feat ?loc graph node_id feat_name new_value =
let set_feat ?loc domain graph node_id feat_name new_value =
let node = Gid_map.find node_id graph.map in
let new_node =
match feat_name with
| "position" -> G_node.set_position (float_of_string new_value) node
| _ ->
let new_fs = G_fs.set_feat ?loc feat_name new_value (G_node.get_fs node) in
let new_fs = G_fs.set_feat ?loc domain feat_name new_value (G_node.get_fs node) in
(G_node.set_fs new_fs node) in
{ graph with map = Gid_map.add node_id new_node graph.map }
(* -------------------------------------------------------------------------------- *)
let update_feat ?loc graph tar_id tar_feat_name item_list =
let update_feat ?loc domain graph tar_id tar_feat_name item_list =
let strings_to_concat =
List.map
(function
......@@ -638,7 +638,7 @@ module G_graph = struct
| Concat_item.String s -> s
) item_list in
let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
(set_feat ?loc graph tar_id tar_feat_name new_feature_value, new_feature_value)
(set_feat ?loc domain graph tar_id tar_feat_name new_feature_value, new_feature_value)
(* -------------------------------------------------------------------------------- *)
let del_feat graph node_id feat_name =
......
......@@ -53,6 +53,7 @@ module P_graph: sig
}
val build:
Domain.t ->
?pat_vars: string list ->
?locals: Label.decl array ->
Ast.node list ->
......@@ -60,6 +61,7 @@ module P_graph: sig
(t * Id.table)
val build_extension:
Domain.t ->
?pat_vars: string list ->
?locals: Label.decl array ->
Id.table ->
......@@ -101,15 +103,15 @@ module G_graph: sig
(* Build functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
val build: ?locals: Label.decl array -> Ast.gr -> t
val build: Domain.t -> ?locals: Label.decl array -> Ast.gr -> t
val of_conll: ?loc:Loc.t -> Conll.t -> t
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.t -> t
(** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/."
It supposes that "SUC" is defined in current relations *)
val of_brown: ?sentid: string -> string -> t
val of_brown: Domain.t -> ?sentid: string -> string -> t
val of_xml: Xml.xml -> t
val of_xml: Domain.t -> Xml.xml -> t
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Update functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
......@@ -145,12 +147,12 @@ module G_graph: sig
(** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
val shift_edges: Loc.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** [update_feat tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
(** [update_feat domain 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: ?loc:Loc.t -> t -> Gid.t -> string -> Concat_item.t list -> (t * string)
val update_feat: ?loc:Loc.t -> Domain.t -> t -> Gid.t -> string -> Concat_item.t list -> (t * string)
val set_feat: ?loc:Loc.t -> t -> Gid.t -> string -> string -> t
val set_feat: ?loc:Loc.t -> Domain.t -> t -> Gid.t -> string -> string -> t
(** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
If the feature is not present, [graph] is returned. *)
......
......@@ -163,11 +163,11 @@ module Modul = struct
| r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
loop [] t.rules
let build ast_module =
let build domain ast_module =
let locals = Array.of_list ast_module.Ast.local_labels in
Array.sort compare locals;
let suffixes = ast_module.Ast.suffixes in
let rules_or_filters = List.map (Rule.build ~locals suffixes ast_module.Ast.mod_dir) ast_module.Ast.rules in
let rules_or_filters = List.map (Rule.build domain ~locals suffixes ast_module.Ast.mod_dir) ast_module.Ast.rules in
let (filters, rules) = List.partition Rule.is_filter rules_or_filters in
let modul =
{
......@@ -218,6 +218,7 @@ end (* module Sequence *)
module Grs = struct
type t = {
domain: Domain.t;
labels: Label.t list; (* the list of global edge labels *)
modules: Modul.t list; (* the ordered list of modules used from rewriting *)
sequences: Sequence.t list;
......@@ -228,10 +229,11 @@ module Grs = struct
let get_modules t = t.modules
let get_ast t = t.ast
let get_filename t = t.filename
let get_domain t = t.domain
let sequence_names t = List.map (fun s -> s.Sequence.name) t.sequences
let empty = {labels=[]; modules=[]; sequences=[]; ast=Ast.empty_grs; filename=""; }
let empty = {domain=Domain.empty; labels=[]; modules=[]; sequences=[]; ast=Ast.empty_grs; filename=""; }
let check t =
(* check for duplicate modules *)
......@@ -252,10 +254,12 @@ module Grs = struct
let build filename =
let ast = Loader.grs filename in
let domain = Domain.build ast.Ast.domain in
Label.init ast.Ast.labels;
Domain.init ast.Ast.domain;
let modules = List.map Modul.build ast.Ast.modules in
let modules = List.map (Modul.build domain) ast.Ast.modules in
let grs = {
domain;
labels = List.map (fun (l,_) -> Label.from_string l) ast.Ast.labels;
sequences = List.map (Sequence.build modules) ast.Ast.sequences;
modules; ast; filename;
......@@ -290,6 +294,7 @@ module Grs = struct
(* printf "Enter module ==> %s\n%!" next.Modul.name; *)
let (good_set, bad_set) =
Rule.normalize
grs.domain
next.Modul.name
~confluent: next.Modul.confluent
next.Modul.rules
......@@ -316,6 +321,7 @@ module Grs = struct
| next :: tail ->
let (good_set, bad_set) =
Rule.normalize
grs.domain
next.Modul.name
~confluent: next.Modul.confluent
next.Modul.rules
......
......@@ -9,6 +9,7 @@
(**********************************************************************************)
open Grew_base
open Grew_types
open Grew_graph
open Grew_rule
open Grew_ast
......@@ -84,6 +85,8 @@ module Grs: sig
val get_ast: t -> Ast.grs
val get_domain: t -> Domain.t
val get_filename: t -> string
val sequence_names: t -> string list
......
......@@ -55,18 +55,18 @@ module G_node = struct
let get_annot_info t = G_fs.get_annot_info t.fs
let build ?def_position (ast_node, loc) =
let fs = G_fs.build ast_node.Ast.fs in
let build domain ?def_position (ast_node, loc) =
let fs = G_fs.build domain ast_node.Ast.fs in
let position = match (ast_node.Ast.position, def_position) with
| (Some position, _) -> position
| (None, Some position) -> position
| (None, None) -> Error.bug "Cannot build a node without position" in
(ast_node.Ast.node_id, { empty with fs; position })
let of_conll ?loc line =
let of_conll ?loc domain line =
if line = Conll.root
then { empty with conll_root=true }
else { empty with fs = G_fs.of_conll ?loc line; position = float line.Conll.num }
else { empty with fs = G_fs.of_conll ?loc domain line; position = float line.Conll.num }
let remove (id_tar : Gid.t) label t = {t with next = Massoc_gid.remove id_tar label t.next}
......@@ -109,11 +109,11 @@ module P_node = struct
let empty = { fs = P_fs.empty; next = Massoc_pid.empty; name = ""; loc=None }
let build ?pat_vars (ast_node, loc) =
let build domain ?pat_vars (ast_node, loc) =
(ast_node.Ast.node_id,
{
name = ast_node.Ast.node_id;
fs = P_fs.build ?pat_vars ast_node.Ast.fs;
fs = P_fs.build domain ?pat_vars ast_node.Ast.fs;
next = Massoc_pid.empty;
loc = Some loc;
} )
......
......@@ -42,8 +42,8 @@ module G_node: sig
val rm_out_edges: t -> t
val add_edge: G_edge.t -> Gid.t -> t -> t option
val build: ?def_position: float -> Ast.node -> (Id.name * t)
val of_conll: ?loc:Loc.t -> Conll.line -> t
val build: Domain.t -> ?def_position: float -> Ast.node -> (Id.name * t)
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.line -> t
val get_position: t -> float
......@@ -77,7 +77,7 @@ module P_node: sig
*)
val unif_fs: P_fs.t -> t -> t
val build: ?pat_vars: string list -> Ast.node -> (Id.name * t)
val build: Domain.t -> ?pat_vars: string list -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> Pid.t -> t -> t option
......
This diff is collapsed.
......@@ -73,13 +73,14 @@ module Rule : sig
(** [to_dep t] returns a string in the [dep] language describing the match basic of the rule *)
val to_dep: t -> string
(** [build ?local dir ast_rule] returns the Rule.t value corresponding to [ast_rule].
(** [build domain ?local dir ast_rule] returns the Rule.t value corresponding to [ast_rule].
[dir] is used for localisation of lp files *)
val build: ?locals:Label.decl array -> string list -> string -> Ast.rule -> t
val build: Domain.t -> ?locals:Label.decl array -> string list -> string -> Ast.rule -> t
(** [normalize module_name ?confluent rule_list filter_list instance] returns two sets of good normal forms and bad normal forms *)
(** [normalize domain module_name ?confluent rule_list filter_list instance] returns two sets of good normal forms and bad normal forms *)
(* raise Stop if some command fails to apply *)
val normalize:
Domain.t ->
string -> (* module name *)
?confluent:bool ->
t list -> (* rule list *)
......@@ -92,7 +93,7 @@ module Rule : sig
type matching
type pattern
val build_pattern: Ast.pattern -> pattern
val build_pattern: Domain.t -> Ast.pattern -> pattern
(** [match_in_graph rule graph] returns the list of matching of the pattern of the rule into the graph *)
val match_in_graph: ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
......
......@@ -29,6 +29,8 @@ let conll_string_of_value = function
| String s -> s
| Float i -> String_.of_float i
type disjunction = value list
let dot_color string =
match (string.[0], String.length string) with
| ('#', 4) -> sprintf "\"#%c%c%c%c%c%c\"" string.[1] string.[1] string.[2] string.[2] string.[3] string.[3]
......@@ -259,9 +261,7 @@ module Domain = struct
type t = feature_spec list
let (current: t option ref) = ref None
let reset () = current := None
let empty = []
let is_defined feature_name domain =
List.exists (function
......@@ -271,6 +271,16 @@ module Domain = struct
| _ -> false
) domain
let rec build = function
| [] -> [Num "position"]
| (Num "position") :: tail -> Log.warning "[Domain] declaration of the feature name \"position\" in useless"; build tail
| (Open "position") :: _
| (Closed ("position",_)) :: _ ->
Error.build "[Domain] The feature named \"position\" is reserved and must be types 'integer', you cannot not redefine it"
| (Num 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 :: (build tail)
let get feature_name domain =
List.find (function
| Closed (fn,_) when fn = feature_name -> true
......@@ -279,36 +289,18 @@ module Domain = struct
| _ -> false
) domain
let check_feature_name ?loc name =
match !current with
| None -> ()
| Some dom when is_defined name dom -> ()
| _ -> Error.build ?loc "The feature name \"%s\" in not defined in the domain" name
let check_feature_name ?loc domain name =
if not (is_defined name domain)
then Error.build ?loc "The feature name \"%s\" in not defined in the domain" name
let is_open name =
match !current with
| None -> true
| Some dom -> List.exists (function Open n when n=name -> true | _ -> false) dom
let is_open domain name =
List.exists (function Open n when n=name -> true | _ -> false) domain
let rec normalize_domain = function
| [] -> [Num "position"]
| (Num "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"
| (Num 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 init domain =
current := Some (normalize_domain domain)
let build ?loc name unsorted_values =
let build_disj ?loc domain 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) ->
match name.[0] with
| '_' -> List.map (fun s -> String s) values (* no check on feat_name starting with '_' *)
| _ ->
let rec loop = function
| [] -> Error.build ?loc "[GRS] Unknown feature name '%s'" name
| ((Open n)::_) when n = name ->
......@@ -325,32 +317,26 @@ module Domain = struct
name
)
| _::t -> loop t in
loop dom
loop domain
let build_one ?loc name value =
match build ?loc name [value] with
let build_value ?loc domain name value =
match build_disj ?loc domain name [value] with
| [x] -> x
| _ -> Error.bug ?loc "[Domain.build_one]"
| _ -> Error.bug ?loc "[Domain.build_value]"
let check_feature ?loc name value =
ignore (build ?loc name [value])
let check_feature ?loc domain name value =
ignore (build_disj ?loc domain name [value])
let feature_names () =
match !current with
| None -> None
| Some dom -> Some (List.map (function Closed (fn, _) | Open fn | Num fn -> fn) dom)
let feature_names domain =
Some (List.map (function Closed (fn, _) | Open fn | Num fn -> fn) domain)
let sub name1 name2 =
match !current with
| None -> true
| Some dom ->
match (get name1 dom, get name2 dom) with
let sub domain name1 name2 =
match (get name1 domain, get name2 domain) with
| (_, Open _) -> true
| (Closed (_,l1), Closed (_,l2)) -> List_.sort_include l1 l2
| (Num _, Num _) -> true
| _ -> false
let build_closed feature_name feature_values =
let sorted_list = List.sort Pervasives.compare feature_values in
let without_duplicate =
......
......@@ -22,6 +22,8 @@ val string_of_value : value -> string
val conll_string_of_value : value -> string
type disjunction = value list
(* ================================================================================ *)
(* [Pid] describes identifier used in pattern graphs *)
module Pid : sig
......@@ -111,30 +113,29 @@ module Domain: sig
| Open of feature_name (* phon, lemma, ... *)
| Num of feature_name (* position *)
type t = feature_spec list
val normalize_domain: t -> t
type t
val reset: unit -> unit
val empty: t
val init: t -> unit
val build: feature_spec list -> t
val build: ?loc:Loc.t -> feature_name -> feature_atom list -> value list