grew_edge.ml 3.91 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3 4 5 6 7 8 9 10
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
(*    Copyright 2011-2013 Inria, Université de Lorraine                           *)
(*                                                                                *)
(*    Webpage: http://grew.loria.fr                                               *)
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11
open Log
12
open Printf
pj2m's avatar
pj2m committed
13

bguillaum's avatar
bguillaum committed
14
open Grew_base
15
open Grew_types
bguillaum's avatar
bguillaum committed
16
open Grew_ast
pj2m's avatar
pj2m committed
17

18 19 20 21
(* ================================================================================ *)
module G_edge = struct
  type t = Label.t

22
  let to_string label_domain ?(locals=[||]) t = Label.to_string label_domain ~locals t
23

24
  let make ?loc label_domain ?(locals=[||]) string = Label.from_string ?loc label_domain ~locals string
25

26
  let build label_domain ?locals (ast_edge, loc) =
bguillaum's avatar
bguillaum committed
27
    match ast_edge.Ast.edge_label_cst with
28
    | ([one], false) -> Label.from_string ~loc label_domain ?locals one
bguillaum's avatar
bguillaum committed
29 30
    | (_, true) -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
    | (_, false) -> Error.build "Only atomic edge valus are allowed in graphs%s" (Loc.to_string loc)
31

32 33
  let to_dep label_domain ?(deco=false) t = Label.to_dep label_domain ~deco t
  let to_dot label_domain ?(deco=false) t = Label.to_dot label_domain ~deco t
bguillaum's avatar
bguillaum committed
34

35 36
  let color_of_option = function
    | [] -> None
37
    | c::_ -> Some (String_.rm_first_char c)
bguillaum's avatar
bguillaum committed
38 39
end (* module G_edge *)

40 41
(* ================================================================================ *)
module P_edge = struct
pj2m's avatar
pj2m committed
42 43
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
bguillaum's avatar
bguillaum committed
44
      u_label: Label_cst.t;
pj2m's avatar
pj2m committed
45 46
    }

bguillaum's avatar
bguillaum committed
47
  let all = {id=None; u_label= Label_cst.all }
bguillaum's avatar
bguillaum committed
48

49
  let get_id t = t.id
pj2m's avatar
pj2m committed
50

51
  let build label_domain ?locals (ast_edge, loc) =
pj2m's avatar
pj2m committed
52
    { id = ast_edge.Ast.edge_id;
53
      u_label = Label_cst.build ~loc label_domain ?locals ast_edge.Ast.edge_label_cst
pj2m's avatar
pj2m committed
54 55
    }

56
  let to_string label_domain t =
bguillaum's avatar
bguillaum committed
57
    match t.id with
58 59
    | None -> Label_cst.to_string label_domain t.u_label
    | Some i -> sprintf "%s:%s" i (Label_cst.to_string label_domain t.u_label)
pj2m's avatar
pj2m committed
60 61 62 63 64 65

  type edge_matcher =
    | Fail
    | Ok of Label.t
    | Binds of string * Label.t list

66
  let match_ label_domain pattern_edge graph_label =
pj2m's avatar
pj2m committed
67
    match pattern_edge with
68 69 70 71
    | {id = Some i; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Binds (i, [graph_label])
    | {id = None; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Ok graph_label
    | {id = Some i; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Binds (i, [graph_label])
    | {id = None; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Ok graph_label
pj2m's avatar
pj2m committed
72 73
    | _ -> Fail

74
  let match_list label_domain pattern_edge graph_edge_list =
pj2m's avatar
pj2m committed
75
    match pattern_edge with
76
    | {id = None; u_label = Label_cst.Pos l} when List.exists (fun label -> Label.match_list label_domain l label) graph_edge_list ->
77
        Ok (List.hd graph_edge_list)
78
    | {id = None; u_label = Label_cst.Neg l} when List.exists (fun label -> not (Label.match_list label_domain l label)) graph_edge_list ->
79
        Ok (List.hd graph_edge_list)
bguillaum's avatar
bguillaum committed
80
    | {id = Some i; u_label = Label_cst.Pos l} ->
81
	(match List.filter (fun label -> Label.match_list label_domain l label) graph_edge_list with
pj2m's avatar
pj2m committed
82 83
	| [] -> Fail
	| list -> Binds (i, list))
bguillaum's avatar
bguillaum committed
84
    | {id = Some i; u_label = Label_cst.Neg l} ->
85
	(match List.filter (fun label -> not (Label.match_list label_domain l label)) graph_edge_list with
pj2m's avatar
pj2m committed
86 87 88
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail
bguillaum's avatar
bguillaum committed
89
end (* module P_edge *)