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

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

bguillaum's avatar
bguillaum committed
24
  let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
25 26 27 28 29 30 31

  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
32 33
  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
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
bguillaum's avatar
bguillaum committed
42
  type u_label =
43 44 45
    | Pos of Label.t list
    | Neg of Label.t list

pj2m's avatar
pj2m committed
46 47
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
48
      u_label: u_label;
pj2m's avatar
pj2m committed
49 50
    }

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

53
  let get_id t = t.id
pj2m's avatar
pj2m committed
54

bguillaum's avatar
bguillaum committed
55 56 57
  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
58 59 60

  let build ?locals (ast_edge, loc) =
    { id = ast_edge.Ast.edge_id;
bguillaum's avatar
bguillaum committed
61
      u_label =
pj2m's avatar
pj2m committed
62 63 64 65 66
      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))
    }

67 68 69
  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
70 71 72 73
    | Pos l -> pref^(List_.to_string Label.to_string "|" l)
    | Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)


74 75 76
  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
77 78 79 80 81 82

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

83
  let match_ pattern_edge graph_label =
pj2m's avatar
pj2m committed
84
    match pattern_edge with
85 86 87 88
    | {id = Some i; u_label = Pos l} when Label.match_list l graph_label -> Binds (i, [graph_label])
    | {id = None; u_label = Pos l} when Label.match_list l graph_label -> Ok graph_label
    | {id = Some i; u_label = Neg l} when not (Label.match_list l graph_label) -> Binds (i, [graph_label])
    | {id = None; u_label = Neg l} when not (Label.match_list l graph_label) -> Ok graph_label
pj2m's avatar
pj2m committed
89 90 91 92
    | _ -> Fail

  let match_list pattern_edge graph_edge_list =
    match pattern_edge with
93
    | {id = None; u_label = Pos l} when List.exists (fun label -> Label.match_list l label) graph_edge_list ->
94
        Ok (List.hd graph_edge_list)
95
    | {id = None; u_label = Neg l} when List.exists (fun label -> not (Label.match_list l label)) graph_edge_list ->
96 97
        Ok (List.hd graph_edge_list)
    | {id = Some i; u_label = Pos l} ->
98
	(match List.filter (fun label -> Label.match_list l label) graph_edge_list with
pj2m's avatar
pj2m committed
99 100
	| [] -> Fail
	| list -> Binds (i, list))
101
    | {id = Some i; u_label = Neg l} ->
102
	(match List.filter (fun label -> not (Label.match_list l label)) graph_edge_list with
pj2m's avatar
pj2m committed
103 104 105
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail
bguillaum's avatar
bguillaum committed
106
end (* module P_edge *)