Commit 2615cb67 authored by bguillaum's avatar bguillaum
Browse files

all pattern edge have a identifier (automatically generated when nothing is given by the user)

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@9114 7838e531-6607-4d57-9587-6c381814729c
parent 03d038be
...@@ -70,43 +70,41 @@ end (* module G_edge *) ...@@ -70,43 +70,41 @@ end (* module G_edge *)
(* ================================================================================ *) (* ================================================================================ *)
module P_edge = struct module P_edge = struct
type t = { type t = {
id: string option; (* an identifier for naming under_label in patterns *) id: string; (* an identifier for naming under_label in patterns *)
label_cst: Label_cst.t; label_cst: Label_cst.t;
} }
let all = {id=None; label_cst=Label_cst.all } let cpt = ref 0
let fresh_name () = incr cpt; sprintf "__e_%d__" !cpt
let all = {id=fresh_name (); label_cst=Label_cst.all }
let get_id t = t.id let get_id t = t.id
let build ?domain (ast_edge, loc) = let build ?domain (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id; { id = (match ast_edge.Ast.edge_id with Some s -> s | None -> fresh_name ());
label_cst = Label_cst.build ~loc ?domain ast_edge.Ast.edge_label_cst label_cst = Label_cst.build ~loc ?domain ast_edge.Ast.edge_label_cst
} }
let to_string ?domain t = let to_string ?domain t =
match t.id with if String.length t.id > 1 && t.id.[0] = '_' && t.id.[1] = '_'
| None -> Label_cst.to_string ?domain t.label_cst then Label_cst.to_string ?domain t.label_cst
| Some i -> sprintf "%s:%s" i (Label_cst.to_string ?domain t.label_cst) else sprintf "%s:%s" t.id (Label_cst.to_string ?domain t.label_cst)
type edge_matcher = type edge_matcher =
| Fail | Fail
| Ok of Label.t
| Binds of string * Label.t list | Binds of string * Label.t list
let match_ ?domain p_edge g_edge = let match_ ?domain p_edge g_edge =
match p_edge with match p_edge with
| {id = None; label_cst } when Label_cst.match_ ?domain label_cst g_edge -> Ok g_edge | {id; label_cst } when Label_cst.match_ ?domain label_cst g_edge -> Binds (id, [g_edge])
| {id = Some i; label_cst } when Label_cst.match_ ?domain label_cst g_edge -> Binds (i, [g_edge])
| _ -> Fail | _ -> Fail
let match_list ?domain p_edge g_edge_list = let match_list ?domain p_edge g_edge_list =
match p_edge with match p_edge with
| {id = None; label_cst} when List.exists (fun g_edge -> Label_cst.match_ ?domain label_cst g_edge) g_edge_list -> | {id; label_cst } ->
Ok (List.hd g_edge_list)
| {id = None} -> Fail
| {id = Some i; label_cst } ->
( match List.filter (fun g_edge -> Label_cst.match_ ?domain label_cst g_edge) g_edge_list with ( match List.filter (fun g_edge -> Label_cst.match_ ?domain label_cst g_edge) g_edge_list with
| [] -> Fail | [] -> Fail
| list -> Binds (i, list) | list -> Binds (id, list)
) )
end (* module P_edge *) end (* module P_edge *)
...@@ -54,7 +54,7 @@ module P_edge: sig ...@@ -54,7 +54,7 @@ module P_edge: sig
(* [all] is the joker pattern edge *) (* [all] is the joker pattern edge *)
val all: t val all: t
val get_id: t -> string option val get_id: t -> string
val to_string: ?domain:Domain.t -> t -> string val to_string: ?domain:Domain.t -> t -> string
...@@ -62,7 +62,6 @@ module P_edge: sig ...@@ -62,7 +62,6 @@ module P_edge: sig
type edge_matcher = type edge_matcher =
| Fail | Fail
| Ok of Label.t
| Binds of string * Label.t list | Binds of string * Label.t list
val match_: ?domain:Domain.t -> t -> G_edge.t -> edge_matcher val match_: ?domain:Domain.t -> t -> G_edge.t -> edge_matcher
......
...@@ -251,7 +251,7 @@ module Rule = struct ...@@ -251,7 +251,7 @@ module Rule = struct
Pid_map.fold Pid_map.fold
(fun _ node acc -> (fun _ node acc ->
Massoc_pid.fold Massoc_pid.fold
(fun acc2 _ edge -> match P_edge.get_id edge with None -> acc2 | Some id -> id::acc2) (fun acc2 _ edge -> (P_edge.get_id edge)::acc2)
acc (P_node.get_next node) acc (P_node.get_next node)
) basic.graph [] ) basic.graph []
...@@ -434,7 +434,6 @@ module Rule = struct ...@@ -434,7 +434,6 @@ module Rule = struct
type matching = { type matching = {
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *) n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *) e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
a_match: (Gid.t*Label.t*Gid.t) list; (* anonymous edge matched *)
m_param: Lex_par.t option; m_param: Lex_par.t option;
} }
...@@ -468,7 +467,7 @@ module Rule = struct ...@@ -468,7 +467,7 @@ module Rule = struct
(P_node.get_name pnode, int_of_float (G_node.get_position gnode)) :: acc (P_node.get_name pnode, int_of_float (G_node.get_position gnode)) :: acc
) n_match [] ) n_match []
let empty_matching param = { n_match = Pid_map.empty; e_match = []; a_match = []; m_param = param;} let empty_matching param = { n_match = Pid_map.empty; e_match = []; m_param = param;}
let e_comp (e1,_) (e2,_) = compare e1 e2 let e_comp (e1,_) (e2,_) = compare e1 e2
...@@ -477,8 +476,6 @@ module Rule = struct ...@@ -477,8 +476,6 @@ module Rule = struct
| Some new_e_match -> { matching with e_match = new_e_match } | Some new_e_match -> { matching with e_match = new_e_match }
| None -> Error.bug "The edge identifier '%s' is binded twice in the same pattern" (fst edge_id) | None -> Error.bug "The edge identifier '%s' is binded twice in the same pattern" (fst edge_id)
let a_match_add edge matching = {matching with a_match = edge::matching.a_match }
let match_deco pattern matching = let match_deco pattern matching =
{ G_deco.nodes = { G_deco.nodes =
Pid_map.fold Pid_map.fold
...@@ -486,7 +483,7 @@ module Rule = struct ...@@ -486,7 +483,7 @@ module Rule = struct
let pnode = P_graph.find pid (fst pattern).graph in let pnode = P_graph.find pid (fst pattern).graph in
(gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc (gid, (P_node.get_name pnode, P_fs.feat_list (P_node.get_fs pnode))) ::acc
) matching.n_match []; ) matching.n_match [];
G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) matching.a_match matching.e_match; G_deco.edges = List.fold_left (fun acc (_,edge) -> edge::acc) [] matching.e_match;
} }
let find cnode ?loc (matching, created_nodes) = let find cnode ?loc (matching, created_nodes) =
...@@ -689,8 +686,6 @@ module Rule = struct ...@@ -689,8 +686,6 @@ module Rule = struct
match P_edge.match_list ?domain p_edge g_edges with match P_edge.match_list ?domain p_edge g_edges with
| P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *) | P_edge.Fail -> (* no good edge in graph for this pattern edge -> stop here *)
[] []
| P_edge.Ok label -> (* at least an edge in the graph fits the p_edge "constraint" -> go on *)
[ {partial with unmatched_edges = tail_ue; sub = a_match_add (src_gid,label,tar_gid) partial.sub} ]
| P_edge.Binds (id,labels) -> (* n edges in the graph match the identified p_edge -> make copies of the [k] matchings (and returns n*k matchings) *) | P_edge.Binds (id,labels) -> (* n edges in the graph match the identified p_edge -> make copies of the [k] matchings (and returns n*k matchings) *)
List.map List.map
(fun label -> (fun label ->
...@@ -706,8 +701,6 @@ module Rule = struct ...@@ -706,8 +701,6 @@ module Rule = struct
match P_edge.match_ ?domain p_edge g_edge with match P_edge.match_ ?domain p_edge g_edge with
| P_edge.Fail -> (* g_edge does not fit, no new candidate *) | P_edge.Fail -> (* g_edge does not fit, no new candidate *)
acc acc
| P_edge.Ok label -> (* g_edge fits with the same matching *)
(gid_next, a_match_add (src_gid, label, gid_next) partial.sub) :: acc
| P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *) | P_edge.Binds (id,[label]) -> (* g_edge fits with an extended matching *)
(gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc (gid_next, e_match_add (id, (src_gid, label, gid_next)) partial.sub) :: acc
| _ -> Error.bug "P_edge.match_ must return exactly one label" | _ -> Error.bug "P_edge.match_ must return exactly one label"
......
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