Attention une mise à jour du service Gitlab va être effectuée le mardi 30 novembre entre 17h30 et 18h00. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes. Cette mise à jour intermédiaire en version 14.0.12 nous permettra de rapidement pouvoir mettre à votre disposition une version plus récente.

grew_edge.ml 5.46 KB
Newer Older
pj2m's avatar
pj2m committed
1
open Log
2
open Printf
pj2m's avatar
pj2m committed
3

bguillaum's avatar
bguillaum committed
4 5
open Grew_utils
open Grew_ast
pj2m's avatar
pj2m committed
6

7
(* ================================================================================ *)
pj2m's avatar
pj2m committed
8
module Label = struct
bguillaum's avatar
bguillaum committed
9
  (* [decl] is the type for a label declaration: the name and an optionnal color *)
pj2m's avatar
pj2m committed
10 11
  type decl = string * string option

bguillaum's avatar
bguillaum committed
12
  (* Global names and colors are recorded in two aligned arrays *)
bguillaum's avatar
bguillaum committed
13
  let full = ref None
pj2m's avatar
pj2m committed
14
  let colors = ref [||]
bguillaum's avatar
bguillaum committed
15 16 17 18 19

  (* Internal representation of labels *)
  type t =
    | Global of int
    | Local of int
bguillaum's avatar
bguillaum committed
20
    | No_domain of string
bguillaum's avatar
bguillaum committed
21 22 23

  (* [init string_edge_list] updates global arrays [full] and [colors] *)
  let init string_edge_list =
pj2m's avatar
pj2m committed
24 25
    let slist = List.sort (fun (x,_) (y,_) -> compare x y) string_edge_list in
    let (labels, cols) = List.split slist in
bguillaum's avatar
bguillaum committed
26
    full := Some (Array.of_list labels);
pj2m's avatar
pj2m committed
27 28
    colors := Array.of_list cols

bguillaum's avatar
bguillaum committed
29 30 31 32 33 34
  let to_string ?(locals=[||]) t =
    match (!full, t) with
      | (None, No_domain s) -> s
      | (Some table, Global i) -> table.(i)
      | (Some _, Local i) -> fst locals.(i)
      | _ -> Error.bug "[Label.to_string] inconsistent data"
pj2m's avatar
pj2m committed
35

bguillaum's avatar
bguillaum committed
36 37
  let to_int = function
    | Global i -> Some i
bguillaum's avatar
bguillaum committed
38
    | _ -> None
bguillaum's avatar
bguillaum committed
39 40

  let from_string ?loc ?(locals=[||]) string =
bguillaum's avatar
bguillaum committed
41 42 43 44 45 46 47
    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
pj2m's avatar
pj2m committed
48

bguillaum's avatar
bguillaum committed
49 50 51 52
  let get_color = function
    | Global l -> !colors.(l)
    | _ -> None
end (* module Label *)
pj2m's avatar
pj2m committed
53 54


55 56 57 58
(* ================================================================================ *)
module G_edge = struct
  type t = Label.t

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

bguillaum's avatar
bguillaum committed
61
  let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80

  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)

  let to_dot ?(deco=false) l =
    match Label.get_color l with
    | None -> Printf.sprintf "[label=\"%s\", color=%s]" (Label.to_string l) (if deco then "red" else "black")
    | Some c -> Printf.sprintf "[label=\"%s\", fontcolor=%s, color=%s]" (Label.to_string l) c (if deco then "red" else "black")

  let to_dep ?(deco=false) l =
    match (deco,Label.get_color l) with
    | (false,None) -> Printf.sprintf "{ label = \"%s\"; }" (Label.to_string l)
    | (false,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=%s; bottom; }" (Label.to_string l) c c
    | (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red}" (Label.to_string l)
    | (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red; bottom; }" (Label.to_string l) c

bguillaum's avatar
bguillaum committed
81 82
end (* module G_edge *)

83 84 85

(* ================================================================================ *)
module P_edge = struct
bguillaum's avatar
bguillaum committed
86
  type u_label =
87 88 89
    | Pos of Label.t list
    | Neg of Label.t list

pj2m's avatar
pj2m committed
90 91
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
92
      u_label: u_label;
pj2m's avatar
pj2m committed
93 94
    }

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

97
  let get_id t = t.id
pj2m's avatar
pj2m committed
98 99

  let make ?(id=None) ?(neg=false) ?(locals=[||]) = function
100 101
    | l when neg -> {id=id; u_label=Neg (List.sort compare (List.map (Label.from_string ~locals) l))}
    | l -> {id=id; u_label=Pos (List.sort compare (List.map (Label.from_string ~locals) l))}
pj2m's avatar
pj2m committed
102 103 104

  let build ?locals (ast_edge, loc) =
    { id = ast_edge.Ast.edge_id;
bguillaum's avatar
bguillaum committed
105
      u_label =
pj2m's avatar
pj2m committed
106 107 108 109 110
      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))
    }

111 112 113
  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
114 115 116 117
    | Pos l -> pref^(List_.to_string Label.to_string "|" l)
    | Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)


118 119 120
  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
121 122 123 124 125 126

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

127
  let match_ pattern_edge graph_label =
pj2m's avatar
pj2m committed
128 129

    match pattern_edge with
130 131 132 133
    | {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
134 135 136 137
    | _ -> Fail

  let match_list pattern_edge graph_edge_list =
    match pattern_edge with
bguillaum's avatar
bguillaum committed
138
    | {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
139 140 141 142 143
        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
144 145
	| [] -> Fail
	| list -> Binds (i, list))
146 147
    | {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
148 149 150 151
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail

bguillaum's avatar
bguillaum committed
152 153
end (* module P_edge *)