grew_edge.ml 8.44 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

14
open Libgrew_utils
bguillaum's avatar
bguillaum committed
15
open Grew_ast
pj2m's avatar
pj2m committed
16

bguillaum's avatar
bguillaum committed
17 18 19

let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)

20
(* ================================================================================ *)
pj2m's avatar
pj2m committed
21
module Label = struct
bguillaum's avatar
bguillaum committed
22
  (** Global names and display styles are recorded in two aligned arrays *)
bguillaum's avatar
bguillaum committed
23
  let full = ref None
bguillaum's avatar
bguillaum committed
24

bguillaum's avatar
bguillaum committed
25
  (** Internal representation of labels *)
bguillaum's avatar
bguillaum committed
26
  type t =
bguillaum's avatar
bguillaum committed
27 28 29
    | Global of int       (* globally defined labels: their names are in the [full] array *)
    | Local of int        (* locally defined labels: names array should be provided! UNTESTED *)
    | No_domain of string (* out of domain label: name in not constrained *)
pj2m's avatar
pj2m committed
30

bguillaum's avatar
bguillaum committed
31
  (** [to_string t] returns a string for the label *)
bguillaum's avatar
bguillaum committed
32 33
  let to_string ?(locals=[||]) t =
    match (!full, t) with
bguillaum's avatar
bguillaum committed
34
      | (_, No_domain s) -> s
bguillaum's avatar
bguillaum committed
35 36 37
      | (Some table, Global i) -> table.(i)
      | (Some _, Local i) -> fst locals.(i)
      | _ -> Error.bug "[Label.to_string] inconsistent data"
pj2m's avatar
pj2m committed
38

bguillaum's avatar
bguillaum committed
39 40
  let to_int = function
    | Global i -> Some i
bguillaum's avatar
bguillaum committed
41
    | _ -> None
bguillaum's avatar
bguillaum committed
42

bguillaum's avatar
bguillaum committed
43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
  (** describe the display style of a label *)
  type line = Solid | Dot | Dash
  type style = {
    text: string;
    bottom: bool;
    color: string option;
    bgcolor: string option;
    line: line;
  }

  (** The [default] style value *)
  let default = { text="UNSET"; bottom=false; color=None; bgcolor=None; line=Solid }

  let styles = ref ([||] : style array)

  let get_style = function
    | Global i -> !styles.(i)
    | Local i -> Log.warning "Style of locally defined labels is not implemented"; default
    | No_domain s -> { default with text=s }

  (** Computes the style of a label from its options and maybe its shape (like I:...). *)
  let parse_option string_label options =
    let init_style = match Str.bounded_split (Str.regexp ":") string_label 2 with
      | ["S"; l] -> {default with text=l; color=Some "red"}
      | ["D"; l] -> {default with text=l; color=Some "blue"; bottom=true}
      | ["I"; l] -> {default with text=l; color=Some "grey"}
      | _ -> {default with text=string_label} in
      List.fold_left
        (fun acc_style -> function
            | "@bottom" -> {acc_style with bottom=true}
            | "@dash" -> {acc_style with line=Dash}
            | "@dot" -> {acc_style with line=Dot}
            | s when String.length s > 4 && String.sub s 0 4 = "@bg_" ->
              let color = String.sub s 4 ((String.length s) - 4) in
              {acc_style with bgcolor=Some color}
            | s -> {acc_style with color=Some (rm_first_char s)}
        ) init_style options

  (** [decl] is the type for a label declaration: the name and a list of display styles *)
  type decl = string * string list

  (* [init decl_list] updates global arrays [full] and [styles] *)
  let init decl_list =
    let slist = List.sort (fun (x,_) (y,_) -> compare x y) decl_list in
    let (labels, opts) = List.split slist in
    let labels_array = Array.of_list labels in
    full := Some labels_array;
    styles := Array.mapi (fun i opt -> parse_option labels_array.(i) opt) (Array.of_list opts)

  let to_dep ?(deco=false) t =
    let style = get_style t in
    let dep_items =
      (if style.bottom then ["bottom"] else [])
      @ (match style.color with Some c -> ["color="^c; "forecolor="^c] | None -> [])
      @ (match style.bgcolor with Some c -> ["bgcolor="^c] | None -> [])
      @ (match style.line with
        | Dot -> ["style=dot"]
        | Dash -> ["style=dash"]
101
        | Solid when deco -> ["bgcolor=yellow"]
bguillaum's avatar
bguillaum committed
102 103 104 105 106 107 108 109 110 111 112 113
        | Solid -> []) in
    sprintf "{ label = \"%s\"; %s}" style.text (String.concat "; " dep_items)

  let to_dot ?(deco=false) t =
    let style = get_style t in
    let dot_items =
      (match style.color with Some c -> ["color="^c; "fontcolor="^c] | None -> [])
      @ (match style.line with
        | Dot -> ["style=dotted"]
        | Dash -> ["style=dashed"]
        | Solid when deco -> ["style=dotted"]
        | Solid -> []) in
bguillaum's avatar
bguillaum committed
114
    sprintf "[label=\"%s\", %s]" style.text (String.concat ", " dot_items)
bguillaum's avatar
bguillaum committed
115

bguillaum's avatar
bguillaum committed
116
  let from_string ?loc ?(locals=[||]) string =
bguillaum's avatar
bguillaum committed
117 118 119 120 121 122 123
    match !full with
      | None -> No_domain string
      | Some table ->
        try Global (Id.build ?loc string table)
        with Not_found ->
          try Local (Array_.dicho_find_assoc string locals)
          with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string
bguillaum's avatar
bguillaum committed
124
end (* module Label *)
pj2m's avatar
pj2m committed
125 126


127 128 129 130
(* ================================================================================ *)
module G_edge = struct
  type t = Label.t

bguillaum's avatar
bguillaum committed
131
  let to_string ?(locals=[||]) t = Label.to_string ~locals t
132

bguillaum's avatar
bguillaum committed
133 134
  let root = Label.No_domain "root"

bguillaum's avatar
bguillaum committed
135
  let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
136 137 138 139 140 141 142

  let build ?locals (ast_edge, loc) =
    match ast_edge.Ast.negative, ast_edge.Ast.edge_labels with
    | (false, [one]) -> Label.from_string ~loc ?locals one
    | (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)

bguillaum's avatar
bguillaum committed
143 144
  let to_dep ?(deco=false) t = Label.to_dep ~deco t
  let to_dot ?(deco=false) t = Label.to_dot ~deco t
bguillaum's avatar
bguillaum committed
145

146 147
  let color_of_option = function
    | [] -> None
bguillaum's avatar
bguillaum committed
148
    | c::_ -> Some (rm_first_char c)
149

bguillaum's avatar
bguillaum committed
150

bguillaum's avatar
bguillaum committed
151 152
end (* module G_edge *)

153 154 155

(* ================================================================================ *)
module P_edge = struct
bguillaum's avatar
bguillaum committed
156
  type u_label =
157 158 159
    | Pos of Label.t list
    | Neg of Label.t list

pj2m's avatar
pj2m committed
160 161
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
162
      u_label: u_label;
pj2m's avatar
pj2m committed
163 164
    }

165
  let all = {id=None; u_label=Neg []}
bguillaum's avatar
bguillaum committed
166

167
  let get_id t = t.id
pj2m's avatar
pj2m committed
168

bguillaum's avatar
bguillaum committed
169 170 171
  let make ?loc ?(id=None) ?(neg=false) ?(locals=[||]) = function
    | l when neg -> {id=id; u_label=Neg (List.sort compare (List.map (Label.from_string ?loc ~locals) l))}
    | l -> {id=id; u_label=Pos (List.sort compare (List.map (Label.from_string ?loc ~locals) l))}
pj2m's avatar
pj2m committed
172 173 174

  let build ?locals (ast_edge, loc) =
    { id = ast_edge.Ast.edge_id;
bguillaum's avatar
bguillaum committed
175
      u_label =
pj2m's avatar
pj2m committed
176 177 178 179 180
      if ast_edge.Ast.negative
      then Neg (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
      else Pos (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
    }

181 182 183
  let to_string t =
    let pref = match t.id with None -> "" | Some i -> sprintf "%s:" i in
    match t.u_label with
pj2m's avatar
pj2m committed
184 185 186 187
    | Pos l -> pref^(List_.to_string Label.to_string "|" l)
    | Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)


188 189 190
  let compatible t g_edge = match t.u_label with
  | Pos p -> List_.sort_mem g_edge p
  | Neg n -> not (List_.sort_mem g_edge n)
pj2m's avatar
pj2m committed
191 192 193 194 195 196

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

197
  let match_ pattern_edge graph_label =
pj2m's avatar
pj2m committed
198 199

    match pattern_edge with
200 201 202 203
    | {id = Some i; u_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label])
    | {id = None; u_label = Pos l} when List.mem graph_label l -> Ok graph_label
    | {id = Some i; u_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label])
    | {id = None; u_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label
pj2m's avatar
pj2m committed
204 205 206 207
    | _ -> Fail

  let match_list pattern_edge graph_edge_list =
    match pattern_edge with
bguillaum's avatar
bguillaum committed
208
    | {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
209 210 211 212 213
        Ok (List.hd graph_edge_list)
    | {id = None; u_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_edge_list ->
        Ok (List.hd graph_edge_list)
    | {id = Some i; u_label = Pos l} ->
	(match List.filter (fun label -> List.mem label l) graph_edge_list with
pj2m's avatar
pj2m committed
214 215
	| [] -> Fail
	| list -> Binds (i, list))
216 217
    | {id = Some i; u_label = Neg l} ->
	(match List.filter (fun label -> not (List.mem label l)) graph_edge_list with
pj2m's avatar
pj2m committed
218 219 220 221
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail

bguillaum's avatar
bguillaum committed
222 223
end (* module P_edge *)