Commit 84bd1cdf authored by Bruno Guillaume's avatar Bruno Guillaume

* Type of Graph.node_matching changed!

New ordering of graph nodes (two subsets) 
parent c51a331f
......@@ -382,11 +382,14 @@ module P_fs = struct
let check_position ?param position t =
try
match List.assoc "position" t with
| {P_feature.cst=P_feature.Equal pos_list; in_param=[]} -> List.mem (Float position) pos_list
| {P_feature.cst=P_feature.Different pos_list; in_param=[]} -> not (List.mem (Float position) pos_list)
| {P_feature.cst=P_feature.Absent} -> false
| _ -> Error.bug "Position can't be parametrized"
match (List.assoc "position" t, position) with
| ({P_feature.cst=P_feature.Equal pos_list; in_param=[]}, Some p) -> List.mem (Float p) pos_list
| ({P_feature.cst=P_feature.Equal pos_list; in_param=[]}, None) -> false
| ({P_feature.cst=P_feature.Different pos_list; in_param=[]}, Some p) -> not (List.mem (Float p) pos_list)
| ({P_feature.cst=P_feature.Different pos_list; in_param=[]}, None) -> false
| ({P_feature.cst=P_feature.Absent}, Some _) -> false
| ({P_feature.cst=P_feature.Absent}, None) -> true
| _ -> Error.bug "Position can't be parametrized"
with Not_found -> true
let build ?domain ?pat_vars ast_fs =
......
......@@ -97,7 +97,7 @@ module P_fs: sig
(** [check_position ?parma position pfs] checks wheter [pfs] is compatible with a node at [position].
It returns [true] iff [pfs] has no requirement about position ok if the requirement is satisfied. *)
val check_position: ?param:Lex_par.t -> float -> t -> bool
val check_position: ?param:Lex_par.t -> float option -> t -> bool
exception Fail_unif
......
......@@ -296,8 +296,8 @@ module G_graph = struct
let node = Gid_map.find node_id graph.map in
Massoc_gid.exists (fun _ e -> Label_cst.match_ ?domain label_cst e) (G_node.get_next node)
let get_annot_info graph =
let annot_info =
let get_annot_info graph = failwith "Unused function !"
(* let annot_info =
Gid_map.fold
(fun _ node acc ->
match (G_node.get_annot_info node, acc) with
......@@ -307,7 +307,7 @@ module G_graph = struct
) graph.map None in
match annot_info with
| Some x -> x
| None -> Error.build "[G_node.get_annot_info] No nodes with annot info"
| None -> Error.build "[G_node.get_annot_info] No nodes with annot info" *)
(* -------------------------------------------------------------------------------- *)
let map_add_edge_opt map id_src label id_tar =
......@@ -350,7 +350,7 @@ module G_graph = struct
else
let (new_tail, table) = loop (node_id :: already_bound) (index+1) (Some index) tail in
let succ = if tail = [] then None else Some (index+1) in
let new_node = G_node.build ?domain ?prec ?succ index (ast_node, loc) in
let new_node = G_node.build ?domain ?prec ?succ ~position:(float index) (ast_node, loc) in
(
Gid_map.add index new_node new_tail,
(node_id,index)::table
......@@ -529,54 +529,62 @@ module G_graph = struct
{ graph with map = new_map }
(* -------------------------------------------------------------------------------- *)
let insert ?domain id1 id2 graph =
let insert id1 id2 graph =
let node1 = Gid_map.find id1 graph.map in
let node2 = Gid_map.find id2 graph.map in
let pos1 = G_node.get_position node1 in
let pos2 = G_node.get_position node2 in
let new_pos= (pos1 +. pos2) /. 2. in
let new_pos = match (G_node.get_position node1, G_node.get_position node2) with
| (G_node.Ordered pos1, G_node.Ordered pos2) -> (pos1 +. pos2) /. 2.
| _ -> Error.run "Try to insert into non ordered nodes" in
let new_gid = graph.highest_index + 1 in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh ?domain ~prec:id1 ~succ:id2 new_pos))
|> (Gid_map.add new_gid (G_node.fresh ~prec:id1 ~succ:id2 new_pos))
|> (Gid_map.add id1 (G_node.set_succ new_gid node1))
|> (Gid_map.add id2 (G_node.set_prec new_gid node2)) in
(new_gid, { graph with map; highest_index = new_gid })
(* -------------------------------------------------------------------------------- *)
let append ?domain id graph =
let append id graph =
let node = Gid_map.find id graph.map in
let pos = G_node.get_position node in
let new_pos= pos +. 1. in
let new_pos = match G_node.get_position node with
| G_node.Ordered pos -> pos +. 1.
| _ -> Error.run "Try to append into non ordered nodes" in
let new_gid = graph.highest_index + 1 in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh ?domain ~prec:id new_pos))
|> (Gid_map.add new_gid (G_node.fresh ~prec:id new_pos))
|> (Gid_map.add id (G_node.set_succ new_gid node)) in
(new_gid, { graph with map; highest_index = new_gid })
(* -------------------------------------------------------------------------------- *)
let prepend ?domain id graph =
let prepend id graph =
let node = Gid_map.find id graph.map in
let pos = G_node.get_position node in
let new_pos= pos -. 1. in
let new_pos = match G_node.get_position node with
| G_node.Ordered pos -> pos -. 1.
| _ -> Error.run "Try to prepend into non ordered nodes" in
let new_gid = graph.highest_index + 1 in
let map = graph.map
|> (Gid_map.add new_gid (G_node.fresh ?domain ~succ:id new_pos))
|> (Gid_map.add new_gid (G_node.fresh ~succ:id new_pos))
|> (Gid_map.add id (G_node.set_prec new_gid node)) in
(new_gid, { graph with map; highest_index = new_gid })
(* -------------------------------------------------------------------------------- *)
let add_after loc ?domain node_id graph =
let add_after node_id graph =
let node = Gid_map.find node_id graph.map in
match G_node.get_succ node with
| Some gid_succ -> insert ?domain node_id gid_succ graph
| None -> append ?domain node_id graph
| Some gid_succ -> insert node_id gid_succ graph
| None -> append node_id graph
(* -------------------------------------------------------------------------------- *)
let add_before loc ?domain node_id graph =
let add_before node_id graph =
let node = Gid_map.find node_id graph.map in
match G_node.get_prec node with
| Some gid_prec -> insert ?domain gid_prec node_id graph
| None -> prepend ?domain node_id graph
| Some gid_prec -> insert gid_prec node_id graph
| None -> prepend node_id graph
(* -------------------------------------------------------------------------------- *)
let add_unordered graph =
let new_gid = graph.highest_index + 1 in
let map = Gid_map.add new_gid (G_node.fresh_unordered ()) graph.map in
(new_gid, { graph with map; highest_index = new_gid })
(* -------------------------------------------------------------------------------- *)
(* move out-edges (which respect cst [labels,neg]) from id_src are moved to out-edges out off node id_tar *)
......@@ -661,7 +669,11 @@ module G_graph = struct
(function
| Concat_item.Feat (node_gid, "position") ->
let node = Gid_map.find node_gid graph.map in
sprintf "%g" (G_node.get_position node)
begin
match G_node.get_position node with
| G_node.Ordered p -> sprintf "%g" p
| _ -> Error.run ?loc "Try to read position of an unordered node"
end
| Concat_item.Feat (node_gid, feat_name) ->
let node = Gid_map.find node_gid graph.map in
(match G_fs.get_string_atom feat_name (G_node.get_fs node) with
......@@ -760,7 +772,8 @@ module G_graph = struct
(fun (id, node) ->
let decorated_feat = try List.assoc id deco.G_deco.nodes with Not_found -> ("",[]) in
let fs = G_node.get_fs node in
let dep_fs = G_fs.to_dep ~decorated_feat ~position:(G_node.get_position node) ?filter ?main_feat fs in
let pos= match G_node.get_position node with G_node.Ordered x -> Some x | _ -> None in
let dep_fs = G_fs.to_dep ~decorated_feat ?position:pos ?filter ?main_feat fs in
let style = match G_fs.get_string_atom "void" fs with
| Some "y" -> "; forecolor=red; subcolor=red; "
......@@ -884,7 +897,7 @@ module G_graph = struct
let gnode = List.assoc gid snodes in
if G_node.is_conll_root gnode
then 0.
else G_node.get_position (List.assoc gid snodes) in
else G_node.get_float (List.assoc gid snodes) in
(* Warning: [govs_labs] maps [gid]s to [num]s *)
let govs_labs =
......
......@@ -137,8 +137,9 @@ module G_graph: sig
[graph] is unchanged if the node is not in it. *)
val del_node: t -> Gid.t -> t
val add_before: Loc.t -> ?domain:Domain.t -> Gid.t -> t -> (Gid.t * t)
val add_after: Loc.t -> ?domain:Domain.t -> Gid.t -> t -> (Gid.t * t)
val add_before: Gid.t -> t -> (Gid.t * t)
val add_after: Gid.t -> t -> (Gid.t * t)
val add_unordered: t -> (Gid.t * t)
(** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
val shift_in: Loc.t -> ?domain:Domain.t -> Gid.t -> Gid.t -> (Gid.t -> bool) -> Label_cst.t -> t -> t
......
......@@ -20,13 +20,17 @@ open Grew_fs
(* ================================================================================ *)
module G_node = struct
type position =
| Ordered of float
| Unordered of int
type t = {
name: Id.name option;
fs: G_fs.t;
next: G_edge.t Massoc_gid.t;
succ: Gid.t option;
prec: Gid.t option;
position: float;
position: position;
conll_root: bool;
efs: (string * string) list;
}
......@@ -38,7 +42,9 @@ module G_node = struct
let set_next next t = {t with next }
let get_position t = t.position
let set_position position t = { t with position }
let set_position p t = { t with position = Ordered p }
let get_float t = match t.position with Ordered p -> p | Unordered i -> float i
let get_prec t = t.prec
let get_succ t = t.succ
......@@ -53,7 +59,7 @@ module G_node = struct
| Some n -> n
| None -> sprintf "_%s_" (Gid.to_string gid)
let empty = { name=None; fs = G_fs.empty; next = Massoc_gid.empty; succ = None; prec = None; position = -1.; conll_root=false; efs=[] }
let empty = { name=None; fs = G_fs.empty; next = Massoc_gid.empty; succ = None; prec = None; position = Unordered 0; conll_root=false; efs=[] }
let is_conll_root t = t.conll_root
......@@ -75,9 +81,13 @@ module G_node = struct
let get_annot_info t = G_fs.get_annot_info t.fs
let build ?domain ?prec ?succ position (ast_node, loc) =
let current_index = ref 0
let fresh_index () = decr current_index; !current_index
let build ?domain ?prec ?succ ?position (ast_node, loc) =
let fs = G_fs.build ?domain ast_node.Ast.fs in
{ empty with name=Some ast_node.Ast.node_id; fs; position = float_of_int position; prec; succ }
let pos = match position with None -> Unordered (fresh_index ()) | Some p -> Ordered p in
{ empty with name=Some ast_node.Ast.node_id; fs; position = pos; prec; succ }
let float_of_conll_id = function
| (i,None) -> float i
......@@ -87,14 +97,15 @@ module G_node = struct
let of_conll ?loc ?prec ?succ ?domain line =
if line = Conll.root
then { empty with conll_root=true; succ}
else { empty with fs = G_fs.of_conll ?loc ?domain line; position = float_of_conll_id line.Conll.id; prec; succ; efs=line.Conll.efs }
else { empty with fs = G_fs.of_conll ?loc ?domain line; position = Ordered (float_of_conll_id line.Conll.id); prec; succ; efs=line.Conll.efs }
let pst_leaf ?loc ?domain phon position =
{ empty with fs = G_fs.pst_leaf ?loc ?domain phon; position = float position }
{ empty with fs = G_fs.pst_leaf ?loc ?domain phon; position = Ordered (float position) }
let pst_node ?loc ?domain cat position =
{ empty with fs = G_fs.pst_node ?loc ?domain cat; position = float position }
{ empty with fs = G_fs.pst_node ?loc ?domain cat; position = Ordered (float position) } (* TODO : change to Unordered *)
let fresh ?domain ?prec ?succ position = { empty with position; prec; succ }
let fresh ?prec ?succ pos = { empty with position = Ordered pos; prec; succ }
let fresh_unordered () = { empty with position = Unordered (fresh_index ())}
let remove (id_tar : Gid.t) label t = {t with next = Massoc_gid.remove id_tar label t.next}
......@@ -169,9 +180,12 @@ module P_node = struct
let match_ ?param p_node g_node =
(* (match param with None -> printf "<None>" | Some p -> printf "<Some>"; Lex_par.dump p); *)
if P_fs.check_position ?param (G_node.get_position g_node) p_node.fs
then P_fs.match_ ?param p_node.fs (G_node.get_fs g_node)
else raise P_fs.Fail
match G_node.get_position g_node with
| G_node.Unordered _ -> None
| G_node.Ordered p ->
if P_fs.check_position ?param (Some p) p_node.fs
then P_fs.match_ ?param p_node.fs (G_node.get_fs g_node)
else raise P_fs.Fail
let compare_pos t1 t2 = Pervasives.compare t1.loc t2.loc
end (* module P_node *)
......@@ -19,6 +19,11 @@ open Grew_ast
(* ================================================================================ *)
module G_node: sig
type position =
| Ordered of float
| Unordered of int
type t
val empty: t
......@@ -40,6 +45,10 @@ module G_node: sig
val set_fs: G_fs.t -> t -> t
val set_position: float -> t -> t
val get_position: t -> position
val get_float: t -> float
val set_next: G_edge.t Massoc_gid.t -> t -> t
val get_name: Gid.t -> t -> string
......@@ -57,14 +66,16 @@ module G_node: sig
val rm_out_edges: t -> t
val add_edge: G_edge.t -> Gid.t -> t -> t option
val build: ?domain:Domain.t -> ?prec:Gid.t -> ?succ:Gid.t -> int -> Ast.node -> t
val build: ?domain:Domain.t -> ?prec:Gid.t -> ?succ:Gid.t -> ?position:float -> Ast.node -> t
val of_conll: ?loc:Loc.t -> ?prec:Gid.t -> ?succ:Gid.t -> ?domain:Domain.t -> Conll.line -> t
val pst_leaf: ?loc:Loc.t -> ?domain:Domain.t -> string -> int -> t
val pst_node: ?loc:Loc.t -> ?domain:Domain.t -> string -> int -> t
val fresh: ?domain:Domain.t -> ?prec:Gid.t -> ?succ:Gid.t -> float -> t
val fresh: ?prec:Gid.t -> ?succ:Gid.t -> float -> t
val fresh_unordered: unit -> t
val get_position: t -> float
val position_comp: t -> t -> int
......
......@@ -594,7 +594,7 @@ module Rule = struct
(fun pid gid acc ->
let pnode = P_graph.find pid (fst pattern).graph in
let gnode = G_graph.find gid graph in
(P_node.get_name pnode, int_of_float (G_node.get_position gnode)) :: acc
(P_node.get_name pnode, G_node.get_float gnode) :: acc
) n_match []
let empty_matching param = { n_match = Pid_map.empty; e_match = []; m_param = param;}
......@@ -684,10 +684,20 @@ module Rule = struct
let apply_cst ?domain graph matching cst =
let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
let get_string_feat pid = function
| "position" -> Some (sprintf "%g" (G_node.get_position (get_node pid)))
| "position" ->
begin
match G_node.get_position (get_node pid) with
| G_node.Ordered f -> Some (sprintf "%g" f)
| _ -> Error.run "Cannot read position of an unordered node"
end
| feat_name -> G_fs.get_string_atom feat_name (G_node.get_fs (get_node pid)) in
let get_float_feat pid = function
| "position" -> Some (G_node.get_position (get_node pid))
| "position" ->
begin
match G_node.get_position (get_node pid) with
| G_node.Ordered f -> Some f
| _ -> Error.run "Cannot read position of an unordered node"
end
| feat_name -> G_fs.get_float_feat feat_name (G_node.get_fs (get_node pid)) in
match cst with
......@@ -1002,33 +1012,32 @@ module Rule = struct
| Command.NEW_AFTER (created_name,base_cn) ->
let base_gid = node_find base_cn in
let (new_gid,new_graph) = G_graph.add_after loc ?domain base_gid instance.Instance.graph in
let (new_gid,new_graph) = G_graph.add_after base_gid instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_NEW_AFTER (created_name,new_gid)) instance.Instance.history;
history = List_.sort_insert (Command.H_NEW_AFTER (created_name,base_gid)) instance.Instance.history;
},
(created_name,new_gid) :: created_nodes
)
| Command.NEW_NODE (created_name) ->
let base_gid = G_graph.get_highest instance.Instance.graph in
let (new_gid,new_graph) = G_graph.add_after loc ?domain base_gid instance.Instance.graph in
let (new_gid,new_graph) = G_graph.add_unordered instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_NEW_AFTER (created_name,new_gid)) instance.Instance.history;
history = List_.sort_insert (Command.H_NEW_NODE created_name) instance.Instance.history;
},
(created_name,new_gid) :: created_nodes
)
| Command.NEW_BEFORE (created_name,base_cn) ->
let base_gid = node_find base_cn in
let (new_gid,new_graph) = G_graph.add_before loc ?domain base_gid instance.Instance.graph in
let (new_gid,new_graph) = G_graph.add_before base_gid instance.Instance.graph in
(
{instance with
Instance.graph = new_graph;
history = List_.sort_insert (Command.H_NEW_BEFORE (created_name,new_gid)) instance.Instance.history;
history = List_.sort_insert (Command.H_NEW_BEFORE (created_name,base_gid)) instance.Instance.history;
},
(created_name,new_gid) :: created_nodes
)
......@@ -1317,8 +1326,4 @@ module Rule = struct
Some (apply_rule ?domain instance first_matching_where_all_witout_are_fulfilled rule)
with Not_found -> None
end (* module Rule *)
......@@ -109,7 +109,7 @@ module Rule : sig
val build_pattern: ?domain:Domain.t -> Ast.pattern -> pattern
(** [node_matching pattern graph matching] return a assoc list (pid_name, gid.position) *)
val node_matching: pattern -> G_graph.t -> matching -> (string * int) list
val node_matching: pattern -> G_graph.t -> matching -> (string * float) list
(** [match_in_graph rule graph] returns the list of matching of the pattern of the rule into the graph *)
val match_in_graph: ?domain:Domain.t -> ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
......
......@@ -100,7 +100,7 @@ module Graph : sig
(** [search_pattern pattern graph] returns the list of the possible matching of [pattern] in [graph] *)
val search_pattern: ?domain:Domain.t -> Pattern.t -> t -> Matching.t list
val node_matching: Pattern.t -> t -> Matching.t -> (string * int) list
val node_matching: Pattern.t -> t -> Matching.t -> (string * float) list
end
(* ==================================================================================================== *)
......
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