register.ml 10.6 KB
Newer Older
1
(* Time-stamp: <modified the 27/07/2021 (at 10:36) by Erwan Jahier> *)
erwan's avatar
erwan committed
2
3
4

type 's neighbor = {
  state:  's ;
Guillaume Raffin's avatar
Guillaume Raffin committed
5
6
7
8
  pid: string;
  spid: string;
  reply: unit -> int;
  weight: unit -> int;
erwan's avatar
erwan committed
9
10
11
}

type algo_id = string
Guillaume Raffin's avatar
Guillaume Raffin committed
12
type action  = string
erwan's avatar
erwan committed
13
14
15
type 's enable_fun = 's neighbor list -> 's -> action list
type 's step_fun   = 's neighbor list -> 's -> action -> 's

16
type pid = string
17
type 's potential_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> float
18
type 's fault_fun = int -> string -> 's -> 's
19
type 's legitimate_fun = string list -> (string -> 's * ('s neighbor * pid) list) -> bool
20

erwan's avatar
erwan committed
21
22
23
24
25
type 's internal_tables = {
  init_state: (string, Obj.t) Hashtbl.t;
  enable   : (string, Obj.t) Hashtbl.t;
  step     : (string, Obj.t) Hashtbl.t;
  value_to_string  : (string, Obj.t) Hashtbl.t;
26
  value_of_string  : (string, Obj.t) Hashtbl.t;
erwan's avatar
erwan committed
27
  copy_value  : (string, Obj.t) Hashtbl.t;
28
  graph_attributes  : (string, string) Hashtbl.t;
29
  mutable potential:  Obj.t;
30
  mutable legitimate:  Obj.t;
31
  mutable fault:  Obj.t;
32
  mutable actions:action list;
erwan's avatar
erwan committed
33
34
35
  mutable topology : Topology.t option;
  mutable card : int option;
  mutable min_deg      : int option;
Guillaume Raffin's avatar
Guillaume Raffin committed
36
  mutable mean_deg     : float option;
erwan's avatar
erwan committed
37
  mutable max_deg      : int option;
38
39
40
  mutable is_cyclic    : bool option;
  mutable is_connected : bool option;
  mutable is_tree      : bool option;
Guillaume Raffin's avatar
Guillaume Raffin committed
41
42
  mutable is_in_tree   : bool option;
  mutable is_out_tree  : bool option;
43
  mutable is_directed  : bool option;
Guillaume Raffin's avatar
Guillaume Raffin committed
44
  mutable level        : (string -> int) option;
erwan's avatar
erwan committed
45
46
47
  mutable height       : (string -> int) option;
  mutable sub_tree_size: (string -> int) option;
  mutable parent       : (string -> int option) option;
Guillaume Raffin's avatar
Guillaume Raffin committed
48
  mutable links_number : int option;
erwan's avatar
erwan committed
49
  mutable diameter     : int option;
50
  }
erwan's avatar
erwan committed
51

52
53
type node_id = string (* cf topology.mli *)

erwan's avatar
erwan committed
54
55
56
57
58
let (tbls:'s internal_tables) = {
  init_state = Hashtbl.create 1;
  enable    = Hashtbl.create 1;
  step      = Hashtbl.create 1;
  value_to_string   = Hashtbl.create 1;
59
  value_of_string   = Hashtbl.create 1;
erwan's avatar
erwan committed
60
  copy_value   = Hashtbl.create 1;
61
  graph_attributes = Hashtbl.create 1;
62
  potential = (Obj.repr None);
63
  legitimate = (Obj.repr None);
64
  fault = (Obj.repr None);
65
  actions   = [];
erwan's avatar
erwan committed
66
67
68
69
70
  topology = None;
  card         = None;
  min_deg      = None;
  mean_deg     = None;
  max_deg      = None;
71
72
73
  is_cyclic    = None;
  is_connected = None;
  is_tree      = None;
erwan's avatar
erwan committed
74
75
  is_in_tree   = None;
  is_out_tree  = None;
76
  is_directed  = None;
Guillaume Raffin's avatar
Guillaume Raffin committed
77
  level        = None;
erwan's avatar
erwan committed
78
79
  height       = None;
  parent       = None;
Guillaume Raffin's avatar
Guillaume Raffin committed
80
  sub_tree_size= None;
erwan's avatar
erwan committed
81
82
  links_number = None;
  diameter     = None
erwan's avatar
erwan committed
83
84
85
86
87
88
89
}

let verbose_level = ref 0
exception Unregistred of string * string

let print_table lbl tbl =
  let keys = Hashtbl.fold (fun k _ acc -> Printf.sprintf "%s,%s" k acc)  tbl "" in
90
  if !verbose_level > 0 then Printf.eprintf "Defined keys for %s: %s\n%!" lbl keys
erwan's avatar
erwan committed
91

92
let (reg_init_state : algo_id -> (int -> string -> 's) -> unit) =
erwan's avatar
erwan committed
93
  fun algo_id x ->
erwan's avatar
erwan committed
94
95
96
  if !verbose_level > 0 then
    Printf.eprintf "Registering %s init_vars\n%!" algo_id;
  Hashtbl.replace tbls.init_state algo_id (Obj.repr x)
erwan's avatar
erwan committed
97

98
let (get_init_state : algo_id -> int -> string -> 's) =
erwan's avatar
erwan committed
99
100
101
102
103
104
  fun algo_id ->
    try Obj.obj (Hashtbl.find tbls.init_state algo_id)
    with Not_found ->
      print_table "init_state" tbls.init_state;
      raise (Unregistred ("init_state", algo_id))

Guillaume Raffin's avatar
Guillaume Raffin committed
105
let (reg_enable : algo_id -> 's enable_fun -> unit) = fun algo_id x ->
106
  if !verbose_level > 0 then Printf.eprintf "Registering %s enable\n%!" algo_id;
erwan's avatar
erwan committed
107
  Hashtbl.replace tbls.enable algo_id (Obj.repr x)
Guillaume Raffin's avatar
Guillaume Raffin committed
108
let (get_enable : algo_id -> 's enable_fun) = fun algo_id ->
erwan's avatar
erwan committed
109
110
111
112
113
  try Obj.obj (Hashtbl.find tbls.enable algo_id)
  with Not_found ->
    print_table "enable" tbls.enable;
    raise (Unregistred ("enable", algo_id))

Guillaume Raffin's avatar
Guillaume Raffin committed
114
let (reg_step : algo_id -> 's step_fun -> unit) = fun algo_id x ->
115
  if !verbose_level > 0 then Printf.eprintf "Registering %s step\n%!" algo_id;
erwan's avatar
erwan committed
116
  Hashtbl.replace tbls.step algo_id (Obj.repr x)
Guillaume Raffin's avatar
Guillaume Raffin committed
117
118

let (get_step : algo_id -> 's step_fun) = fun algo_id ->
erwan's avatar
erwan committed
119
120
121
122
123
  try Obj.obj (Hashtbl.find tbls.step algo_id)
  with Not_found ->
    print_table "step" tbls.step;
    raise (Unregistred ("step", algo_id))

Guillaume Raffin's avatar
Guillaume Raffin committed
124
let (reg_potential : 's potential_fun option -> unit) = fun x ->
125
126
  if !verbose_level > 0 then Printf.eprintf "Registering potential\n%!";
  tbls.potential <- (Obj.repr x)
Guillaume Raffin's avatar
Guillaume Raffin committed
127
128

let (get_potential : unit -> 's potential_fun option) = fun () ->
129
  Obj.obj tbls.potential
Guillaume Raffin's avatar
Guillaume Raffin committed
130
131

let (reg_fault : 's fault_fun option -> unit) = fun x ->
132
133
  if !verbose_level > 0 then Printf.eprintf "Registering fault function\n%!";
  tbls.fault <- (Obj.repr x)
Guillaume Raffin's avatar
Guillaume Raffin committed
134
135

let (get_fault : unit -> 's fault_fun option) = fun () ->
136
  Obj.obj tbls.fault
137

Guillaume Raffin's avatar
Guillaume Raffin committed
138
let (reg_legitimate : 's legitimate_fun option -> unit) = fun x ->
139
140
  if !verbose_level > 0 then Printf.eprintf "Registering legitimate function\n%!";
  tbls.legitimate <- (Obj.repr x)
Guillaume Raffin's avatar
Guillaume Raffin committed
141
142

let (get_legitimate : unit -> 's legitimate_fun option) = fun () ->
143
144
  Obj.obj tbls.legitimate

145
let (reg_actions : action list -> unit) =
Guillaume Raffin's avatar
Guillaume Raffin committed
146
  fun x ->
147
148
  if !verbose_level > 0 then Printf.eprintf "Registering actions\n%!";
   tbls.actions <- x
Guillaume Raffin's avatar
Guillaume Raffin committed
149
150
let (get_actions : unit -> action list) = fun () ->
  tbls.actions
erwan's avatar
erwan committed
151
152

let (reg_value_to_string : ('s -> string) -> unit) =
Guillaume Raffin's avatar
Guillaume Raffin committed
153
  fun f ->
154
  if !verbose_level > 0 then Printf.eprintf "Registering value_to_string\n%!";
erwan's avatar
erwan committed
155
  Hashtbl.replace tbls.value_to_string "_global" (Obj.repr f)
Guillaume Raffin's avatar
Guillaume Raffin committed
156
let (get_value_to_string : unit -> 's -> string) = fun () ->
erwan's avatar
erwan committed
157
158
159
160
161
  try Obj.obj (Hashtbl.find tbls.value_to_string "_global")
  with Not_found ->
    print_table "value_to_string" tbls.value_to_string;
    raise (Unregistred ("value_to_string", "_global"))

162
let (reg_value_of_string : (string -> 's) -> unit) =
Guillaume Raffin's avatar
Guillaume Raffin committed
163
  fun f ->
164
  if !verbose_level > 0 then Printf.eprintf "Registering value_of_string\n%!";
165
  Hashtbl.replace tbls.value_of_string "_global" (Obj.repr f)
Guillaume Raffin's avatar
Guillaume Raffin committed
166
let (get_value_of_string : unit -> (string -> 's) option) = fun () ->
167
168
  try Some (Obj.obj (Hashtbl.find tbls.value_of_string "_global"))
  with Not_found -> None
169

erwan's avatar
erwan committed
170
let (reg_copy_value : ('s -> 's) -> unit) =
Guillaume Raffin's avatar
Guillaume Raffin committed
171
  fun f ->
172
  if !verbose_level > 0 then Printf.eprintf "Registering copy_value\n%!";
erwan's avatar
erwan committed
173
  Hashtbl.replace tbls.copy_value "_global" (Obj.repr f)
Guillaume Raffin's avatar
Guillaume Raffin committed
174
175

let (get_copy_value : unit ->  ('s -> 's)) = fun () ->
erwan's avatar
erwan committed
176
177
178
179
180
181
  try Obj.obj (Hashtbl.find tbls.copy_value "_global")
  with Not_found ->
    print_table "copy_value" tbls.copy_value;
    raise (Unregistred ("copy_value", "_global"))


erwan's avatar
erwan committed
182
183
184
185
let set_topology g = tbls.topology <- Some g
let get_topology () = match tbls.topology with
  | None -> assert false (* SNO if set_topology is called in Main *)
  | Some g -> g
Guillaume Raffin's avatar
Guillaume Raffin committed
186

187
let (card : unit -> int) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
188
  match tbls.card with
erwan's avatar
erwan committed
189
190
191
192
193
  | None ->
    let x = List.length  (get_topology()).nodes in
    tbls.card <- Some x;
    x
  | Some b -> b
194

195
let (is_directed : unit -> bool) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
196
  match tbls.is_directed with
197
  | None ->
erwan's avatar
erwan committed
198
199
200
201
    let x =  (get_topology()).directed in
    tbls.is_directed <- Some x;
    x
  | Some b -> b
Guillaume Raffin's avatar
Guillaume Raffin committed
202

203
let (mean_degree : unit -> float) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
204
  match tbls.mean_deg with
erwan's avatar
erwan committed
205
206
207
208
209
  | None ->
    let x = Topology.get_mean_degree (get_topology()) in
    tbls.mean_deg <- Some x;
    x
  | Some b -> b
210

erwan's avatar
erwan committed
211
let (min_degree : unit -> int) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
212
  match tbls.min_deg with
erwan's avatar
erwan committed
213
214
215
216
217
218
219
220
  | None ->
    let mind,maxd = Topology.get_degree (get_topology()) in
    tbls.max_deg <- Some maxd;
    tbls.min_deg <- Some mind;
    mind
  | Some b -> b

let (max_degree : unit -> int) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
221
  match tbls.max_deg with
erwan's avatar
erwan committed
222
223
224
225
226
227
  | None ->
    let mind,maxd = Topology.get_degree (get_topology()) in
    tbls.max_deg <- Some maxd;
    tbls.min_deg <- Some mind;
    maxd
  | Some b -> b
228

229
let (is_cyclic : unit -> bool) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
230
  match tbls.is_cyclic with
231
  | None ->
erwan's avatar
erwan committed
232
    let cyclic = Topology.is_cyclic (get_topology()) in
erwan's avatar
erwan committed
233
234
    tbls.is_cyclic <- Some cyclic;
    cyclic
235
  | Some b -> b
236

237
let (is_connected : unit -> bool) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
238
  match tbls.is_connected with
erwan's avatar
erwan committed
239
  | None ->
erwan's avatar
erwan committed
240
    let connect = Topology.is_connected (get_topology()) in
erwan's avatar
erwan committed
241
242
    tbls.is_connected <- Some connect;
    connect
243
  | Some b -> b
Guillaume Raffin's avatar
Guillaume Raffin committed
244

245
let (is_tree : unit -> bool) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
246
  match tbls.is_tree with
247
  | None ->
erwan's avatar
erwan committed
248
     let b = Topology.is_tree (get_topology()) in
249
250
     tbls.is_tree <- Some b;
     b
251
  | Some b -> b
252

erwan's avatar
erwan committed
253
let (is_in_tree : unit -> bool) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
254
  match tbls.is_in_tree with
erwan's avatar
erwan committed
255
256
257
258
259
  | None ->
     let b = Topology.is_in_tree (get_topology()) in
     tbls.is_in_tree <- Some b;
     b
  | Some b -> b
erwan's avatar
erwan committed
260

erwan's avatar
erwan committed
261
let (is_out_tree : unit -> bool) = fun () ->
Guillaume Raffin's avatar
Guillaume Raffin committed
262
  match tbls.is_out_tree with
erwan's avatar
erwan committed
263
264
265
266
267
268
269
270
271
  | None ->
     let b = Topology.is_out_tree (get_topology()) in
     tbls.is_out_tree <- Some b;
     b
  | Some b -> b

let not_a_tree () = failwith "The graph is not a tree"

let height : (string -> int) =
Guillaume Raffin's avatar
Guillaume Raffin committed
272
  fun pid ->
erwan's avatar
erwan committed
273
274
  if is_tree () then (
    match tbls.height with
erwan's avatar
erwan committed
275
    | Some h -> h pid
erwan's avatar
erwan committed
276
277
    | None ->
      let h = Topology.get_height (get_topology ()) in
erwan's avatar
erwan committed
278
      tbls.height <- Some h; h pid
erwan's avatar
erwan committed
279
  )
erwan's avatar
erwan committed
280
  else not_a_tree ()
erwan's avatar
erwan committed
281

Guillaume Raffin's avatar
Guillaume Raffin committed
282
283
284
285
286
287
288
289
290
291
292
let level: (string -> int) =
  fun pid ->
  if is_tree () then (
    match tbls.level with
    | Some l -> l pid
    | None ->
      let l = Topology.get_level (get_topology ()) in
      tbls.level <- Some l; l pid
  )
  else not_a_tree ()

erwan's avatar
erwan committed
293
let sub_tree_size : (string -> int) =
Guillaume Raffin's avatar
Guillaume Raffin committed
294
  fun pid ->
erwan's avatar
erwan committed
295
296
  if is_tree () then (
    match tbls.sub_tree_size with
erwan's avatar
erwan committed
297
    | Some s -> s pid
erwan's avatar
erwan committed
298
    | None ->
Guillaume Raffin's avatar
Guillaume Raffin committed
299
      let s = Topology.get_subtree_size (get_topology ()) in
erwan's avatar
erwan committed
300
      tbls.sub_tree_size <- Some s; s pid
erwan's avatar
erwan committed
301
  )
erwan's avatar
erwan committed
302
  else not_a_tree ()
erwan's avatar
erwan committed
303

erwan's avatar
erwan committed
304
let parent : (string -> int option) =
Guillaume Raffin's avatar
Guillaume Raffin committed
305
  fun pid ->
erwan's avatar
erwan committed
306
    match tbls.parent with
erwan's avatar
erwan committed
307
    | Some p -> p pid
erwan's avatar
erwan committed
308
309
    | None ->
      let p = Topology.get_parent (get_topology ()) in
erwan's avatar
erwan committed
310
      tbls.parent <- Some p; p pid
311

312

Guillaume Raffin's avatar
Guillaume Raffin committed
313
let (links_number : unit -> int) =
314
  fun () ->
erwan's avatar
erwan committed
315
316
317
318
319
320
  match tbls.links_number with
  | Some x -> x
  | None ->
    let x = Topology.get_nb_link  (get_topology ()) in
    tbls.links_number <- Some x;
    x
321

Guillaume Raffin's avatar
Guillaume Raffin committed
322
323
let (diameter : unit -> int) =
  fun () ->
324
  if not (is_connected()) then failwith "diameter: the graph is not connected";
325
  match tbls.diameter with
erwan's avatar
erwan committed
326
327
  | Some x -> x
  | None ->
328
    let x = Diameter.get (get_topology ()) in
erwan's avatar
erwan committed
329
330
    tbls.diameter <- Some x;
    x
Guillaume Raffin's avatar
Guillaume Raffin committed
331

erwan's avatar
erwan committed
332
333
334
let (to_string : 's -> string) =
  fun v ->
    (get_value_to_string ()) v
335

336
let (get_graph_attribute : string -> string) =
337
  fun str ->
Guillaume Raffin's avatar
Guillaume Raffin committed
338
    try Hashtbl.find tbls.graph_attributes str
339
340
341
    with Not_found ->
      failwith (Printf.sprintf "The graph attribute %s does not seem to exist" str)

Guillaume Raffin's avatar
Guillaume Raffin committed
342
343
344
345
let (get_graph_attribute_opt : string -> string option) =
  fun str ->
    Hashtbl.find_opt tbls.graph_attributes str

346
let (set_graph_attribute : string -> string -> unit) =
Guillaume Raffin's avatar
Guillaume Raffin committed
347
  Hashtbl.replace tbls.graph_attributes
348
349
350
351

let (graph_attribute_list: unit -> (string * string)  list) =
  fun () ->
    Hashtbl.fold (fun n v acc -> (n,v)::acc) tbls.graph_attributes []
Guillaume Raffin's avatar
Guillaume Raffin committed
352
353
354
355
356

let (is_rooted_tree : unit -> bool) = fun () ->
  match get_graph_attribute_opt "is_rooted" with
  | None -> false
  | Some str -> bool_of_string str