register.ml

(* Time-stamp: <modified the 27/07/2021 (at 10:36) by Erwan Jahier> *)

type 's neighbor = {
  state:  's ;
  pid: string;
  spid: string;
  reply: unit -> int;
  weight: unit -> int;
}

type algo_id = string
type action  = string
type 's enable_fun = 's neighbor list -> 's -> action list
type 's step_fun   = 's neighbor list -> 's -> action -> 's

type pid = string
type 's potential_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> float
type 's fault_fun = int -> string -> 's -> 's
type 's legitimate_fun = string list -> (string -> 's * ('s neighbor * pid) list) -> bool

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;
  value_of_string  : (string, Obj.t) Hashtbl.t;
  copy_value  : (string, Obj.t) Hashtbl.t;
  graph_attributes  : (string, string) Hashtbl.t;
  mutable potential:  Obj.t;
  mutable legitimate:  Obj.t;
  mutable fault:  Obj.t;
  mutable actions:action list;
  mutable topology : Topology.t option;
  mutable card : int option;
  mutable min_deg      : int option;
  mutable mean_deg     : float option;
  mutable max_deg      : int option;
  mutable is_cyclic    : bool option;
  mutable is_connected : bool option;
  mutable is_tree      : bool option;
  mutable is_in_tree   : bool option;
  mutable is_out_tree  : bool option;
  mutable is_directed  : bool option;
  mutable level        : (string -> int) option;
  mutable height       : (string -> int) option;
  mutable sub_tree_size: (string -> int) option;
  mutable parent       : (string -> int option) option;
  mutable links_number : int option;
  mutable diameter     : int option;
  }

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

let (tbls:'s internal_tables) = {
  init_state = Hashtbl.create 1;
  enable    = Hashtbl.create 1;
  step      = Hashtbl.create 1;
  value_to_string   = Hashtbl.create 1;
  value_of_string   = Hashtbl.create 1;
  copy_value   = Hashtbl.create 1;
  graph_attributes = Hashtbl.create 1;
  potential = (Obj.repr None);
  legitimate = (Obj.repr None);
  fault = (Obj.repr None);
  actions   = [];
  topology = None;
  card         = None;
  min_deg      = None;
  mean_deg     = None;
  max_deg      = None;
  is_cyclic    = None;
  is_connected = None;
  is_tree      = None;
  is_in_tree   = None;
  is_out_tree  = None;
  is_directed  = None;
  level        = None;
  height       = None;
  parent       = None;
  sub_tree_size= None;
  links_number = None;
  diameter     = None
}

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
  if !verbose_level > 0 then Printf.eprintf "Defined keys for %s: %s\n%!" lbl keys

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

let (get_init_state : algo_id -> int -> string -> 's) =
  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))

let (reg_enable : algo_id -> 's enable_fun -> unit) = fun algo_id x ->
  if !verbose_level > 0 then Printf.eprintf "Registering %s enable\n%!" algo_id;
  Hashtbl.replace tbls.enable algo_id (Obj.repr x)
let (get_enable : algo_id -> 's enable_fun) = fun algo_id ->
  try Obj.obj (Hashtbl.find tbls.enable algo_id)
  with Not_found ->
    print_table "enable" tbls.enable;
    raise (Unregistred ("enable", algo_id))

let (reg_step : algo_id -> 's step_fun -> unit) = fun algo_id x ->
  if !verbose_level > 0 then Printf.eprintf "Registering %s step\n%!" algo_id;
  Hashtbl.replace tbls.step algo_id (Obj.repr x)

let (get_step : algo_id -> 's step_fun) = fun algo_id ->
  try Obj.obj (Hashtbl.find tbls.step algo_id)
  with Not_found ->
    print_table "step" tbls.step;
    raise (Unregistred ("step", algo_id))

let (reg_potential : 's potential_fun option -> unit) = fun x ->
  if !verbose_level > 0 then Printf.eprintf "Registering potential\n%!";
  tbls.potential <- (Obj.repr x)

let (get_potential : unit -> 's potential_fun option) = fun () ->
  Obj.obj tbls.potential

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

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

let (reg_legitimate : 's legitimate_fun option -> unit) = fun x ->
  if !verbose_level > 0 then Printf.eprintf "Registering legitimate function\n%!";
  tbls.legitimate <- (Obj.repr x)

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

let (reg_actions : action list -> unit) =
  fun x ->
  if !verbose_level > 0 then Printf.eprintf "Registering actions\n%!";
   tbls.actions <- x
let (get_actions : unit -> action list) = fun () ->
  tbls.actions

let (reg_value_to_string : ('s -> string) -> unit) =
  fun f ->
  if !verbose_level > 0 then Printf.eprintf "Registering value_to_string\n%!";
  Hashtbl.replace tbls.value_to_string "_global" (Obj.repr f)
let (get_value_to_string : unit -> 's -> string) = fun () ->
  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"))

let (reg_value_of_string : (string -> 's) -> unit) =
  fun f ->
  if !verbose_level > 0 then Printf.eprintf "Registering value_of_string\n%!";
  Hashtbl.replace tbls.value_of_string "_global" (Obj.repr f)
let (get_value_of_string : unit -> (string -> 's) option) = fun () ->
  try Some (Obj.obj (Hashtbl.find tbls.value_of_string "_global"))
  with Not_found -> None

let (reg_copy_value : ('s -> 's) -> unit) =
  fun f ->
  if !verbose_level > 0 then Printf.eprintf "Registering copy_value\n%!";
  Hashtbl.replace tbls.copy_value "_global" (Obj.repr f)

let (get_copy_value : unit ->  ('s -> 's)) = fun () ->
  try Obj.obj (Hashtbl.find tbls.copy_value "_global")
  with Not_found ->
    print_table "copy_value" tbls.copy_value;
    raise (Unregistred ("copy_value", "_global"))


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

let (card : unit -> int) = fun () ->
  match tbls.card with
  | None ->
    let x = List.length  (get_topology()).nodes in
    tbls.card <- Some x;
    x
  | Some b -> b

let (is_directed : unit -> bool) = fun () ->
  match tbls.is_directed with
  | None ->
    let x =  (get_topology()).directed in
    tbls.is_directed <- Some x;
    x
  | Some b -> b

let (mean_degree : unit -> float) = fun () ->
  match tbls.mean_deg with
  | None ->
    let x = Topology.get_mean_degree (get_topology()) in
    tbls.mean_deg <- Some x;
    x
  | Some b -> b

let (min_degree : unit -> int) = fun () ->
  match tbls.min_deg with
  | 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 () ->
  match tbls.max_deg with
  | None ->
    let mind,maxd = Topology.get_degree (get_topology()) in
    tbls.max_deg <- Some maxd;
    tbls.min_deg <- Some mind;
    maxd
  | Some b -> b

let (is_cyclic : unit -> bool) = fun () ->
  match tbls.is_cyclic with
  | None ->
    let cyclic = Topology.is_cyclic (get_topology()) in
    tbls.is_cyclic <- Some cyclic;
    cyclic
  | Some b -> b

let (is_connected : unit -> bool) = fun () ->
  match tbls.is_connected with
  | None ->
    let connect = Topology.is_connected (get_topology()) in
    tbls.is_connected <- Some connect;
    connect
  | Some b -> b

let (is_tree : unit -> bool) = fun () ->
  match tbls.is_tree with
  | None ->
     let b = Topology.is_tree (get_topology()) in
     tbls.is_tree <- Some b;
     b
  | Some b -> b

let (is_in_tree : unit -> bool) = fun () ->
  match tbls.is_in_tree with
  | None ->
     let b = Topology.is_in_tree (get_topology()) in
     tbls.is_in_tree <- Some b;
     b
  | Some b -> b

let (is_out_tree : unit -> bool) = fun () ->
  match tbls.is_out_tree with
  | 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) =
  fun pid ->
  if is_tree () then (
    match tbls.height with
    | Some h -> h pid
    | None ->
      let h = Topology.get_height (get_topology ()) in
      tbls.height <- Some h; h pid
  )
  else not_a_tree ()

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 ()

let sub_tree_size : (string -> int) =
  fun pid ->
  if is_tree () then (
    match tbls.sub_tree_size with
    | Some s -> s pid
    | None ->
      let s = Topology.get_subtree_size (get_topology ()) in
      tbls.sub_tree_size <- Some s; s pid
  )
  else not_a_tree ()

let parent : (string -> int option) =
  fun pid ->
    match tbls.parent with
    | Some p -> p pid
    | None ->
      let p = Topology.get_parent (get_topology ()) in
      tbls.parent <- Some p; p pid


let (links_number : unit -> int) =
  fun () ->
  match tbls.links_number with
  | Some x -> x
  | None ->
    let x = Topology.get_nb_link  (get_topology ()) in
    tbls.links_number <- Some x;
    x

let (diameter : unit -> int) =
  fun () ->
  if not (is_connected()) then failwith "diameter: the graph is not connected";
  match tbls.diameter with
  | Some x -> x
  | None ->
    let x = Diameter.get (get_topology ()) in
    tbls.diameter <- Some x;
    x

let (to_string : 's -> string) =
  fun v ->
    (get_value_to_string ()) v

let (get_graph_attribute : string -> string) =
  fun str ->
    try Hashtbl.find tbls.graph_attributes str
    with Not_found ->
      failwith (Printf.sprintf "The graph attribute %s does not seem to exist" str)

let (get_graph_attribute_opt : string -> string option) =
  fun str ->
    Hashtbl.find_opt tbls.graph_attributes str

let (set_graph_attribute : string -> string -> unit) =
  Hashtbl.replace tbls.graph_attributes

let (graph_attribute_list: unit -> (string * string)  list) =
  fun () ->
    Hashtbl.fold (fun n v acc -> (n,v)::acc) tbls.graph_attributes []

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