path: root/sources/thibaut/globals.ml

type state = ON | OFF

let string_of_state state = match state with
  | ON -> "On"
  | OFF -> "Off"
	
let state_of_string s = match s with
  | "On" -> ON
  | "Off" -> OFF
  | _ -> failwith (Printf.sprintf "Wrong state:%s" s)
      
type phase = SEEDING | IDLE | PULSE
type peer_id = int

module PeerId = struct
  type t = peer_id
  let compare = Pervasives.compare
end

module HashMap = Map2.Make(PeerId)

module RoundMap : sig
  type 'a t
    
  val empty : 'a t
  val add : int -> 'a -> 'a t -> 'a t
  val mem : int -> 'a t -> bool
  val find : int -> 'a t -> 'a
  val iter : (int -> 'a -> unit) -> 'a t -> unit
  val iter_limit : (int -> 'a -> unit) -> int -> 'a t -> unit
  val last_round : 'a t -> int
  val truncate : int -> 'a t -> 'a t
    
end = struct

  type 'a t = (int* 'a) list
      
  let add round data map = (round,data)::map
    
  let last_round map = match map with
    | [] -> 0
    | (a,b)::c -> a
	
  let empty = []
    
  let rec mem round map = match map with
    | [] -> false
    | (a,b)::c -> 
	if a = round then true
	else if a < round then false
	else mem round c
	  
  let rec find round map = match map with
    | [] -> raise Not_found
    | (a,b)::c ->
	if a = round then b
	else if a < round then raise Not_found
	else find round c
	  
  let rec iter f map = match map with
    | [] -> ()
    | (a,b)::c -> f a b; iter f c
	
  let rec iter_limit f limit map = match map with
    | [] -> ()
    | (a,b)::c ->
	if a >= limit then begin
	  f a b;
	  iter_limit f limit c
	end
	  
  let rec truncate limit map = match map with
    | [] -> []
    | (a,b)::c ->
	if a < limit then
	  []
	else
	  (a,b)::(truncate limit c) 
end

type message_content = 
  | Seed of int * int (* seed, duration *)
  | SeedReply of int (* hash *)
  | Pulse of int * int HashMap.t list (* seed, branch *)

type message = {
  sender : peer_id;
  round : int;
  content : message_content
} 

type round_data = {
  mutable phase : phase;
  duration : int;
  seed : int;
  mutable hmap : int HashMap.t;
  replies : (int * int HashMap.t) Queue.t
}

module SlotArray : sig
  exception SlotArray of string
  type 'a slot = Peer of 'a | Ask of 'a | AskRoot | Empty
  type 'a t
  val make : int -> 'a t
  val full : 'a t -> bool
  val accept : 'a slot -> 'a t -> unit
  val clear : 'a t -> unit
  val iter : ('a slot -> unit) -> 'a t -> unit
  val ask_list : 'a t -> ('a slot) array
  val test : ('a slot -> bool) -> 'a t -> bool
  val random_peer_avoid : ('a slot -> bool) -> 'a t -> 'a slot
  val random_peer : 'a t -> 'a slot
  val filter_peers : ('a slot -> bool) -> 'a t -> unit
  val iter_asks : ('a slot -> 'a slot) -> 'a t -> unit
  val capacity : 'a t -> int
  val length : 'a t -> int
  val asks : 'a t -> int
  val append_asks : ('a slot array) -> 'a t -> unit
		
end = struct
  exception SlotArray of string
  type 'a slot = Peer of 'a | Ask of 'a | AskRoot | Empty
      
  type 'a t = {
    mutable npeers : int;
    mutable nasks : int; 
    peers: ('a slot) array;
    capacity: int;
    asks: ('a slot) array
  }
      
  let full sa = ( sa.npeers = sa.capacity )
    
  let add_peer elem sa =
    let length = sa.npeers in
      sa.peers.(length) <- elem;
      sa.npeers <- (length + 1)
	
  let remove_peer pos sa = 
    let length = sa.npeers -1 in
      sa.peers.(pos) <- sa.peers.(length);
      sa.peers.(length) <- Empty;
      sa.npeers <- length
	
  let add_ask elem sa =
    let length = sa.nasks in
      sa.asks.(length) <- elem;
      sa.nasks <- (length + 1)
	
  let remove_ask pos sa =
    let length = sa.nasks -1 in
      sa.asks.(pos) <- sa.asks.(length);
      sa.asks.(length) <- Empty;
      sa.nasks <- length
	
  let iter_asks f sa = 
    let rec aux n =
      if n < sa.nasks && not (full sa) then
	match f sa.asks.(n) with
	  | Ask _ as e -> sa.asks.(n) <- e; aux (n+1)
	  | AskRoot -> remove_ask n sa; aux n
	  | Peer _ as e -> add_peer e sa; remove_ask n sa; aux n
	  | _ -> raise (SlotArray "iter_asks")
    in
      aux 0
	
  let filter_peers pred sa =
    let rec aux n =
      if n < sa.npeers then
        if not (pred sa.peers.(n)) then begin
          remove_peer n sa;
          aux n
        end
        else
          aux (n+1)
    in
      aux 0
        
  let clear sa = 
    for i = 0 to sa.npeers - 1 do
      sa.peers.(i) <- Empty
    done;
    sa.npeers <- 0
      
  let make capacity = {
    peers = Array.make capacity Empty;
    asks = Array.make capacity Empty;
    nasks = 0;
    npeers = 0;
    capacity = capacity
  }

  let length sa = sa.npeers
  let asks sa = sa.nasks
  let capacity sa = sa.capacity
    
  let test pred sa = 
    let rec aux n = 
      if n = sa.npeers then false
      else (pred sa.peers.(n))||(aux (n+1))
    in
      aux 0
	
  let accept p sa = add_peer p sa
    
  let iter f sa =
    for i = 0 to sa.npeers -1 do
      f sa.peers.(i)
    done
      
  let random_peer sa =
    let n = Random.int sa.npeers in
      sa.peers.(n)
        
  let random_peer_avoid pred sa =
    if sa.npeers <= 1 then AskRoot
    else let n = Random.int sa.npeers in
      if pred sa.peers.(n) then 
        if n = sa.npeers - 1 then sa.peers.(n-1)
        else sa.peers.(n+1)
      else
        sa.peers.(n)
          
  let ask_list sa =
    sa.peers
      
  let append_asks list sa =
    let rec aux n =
      if sa.nasks < sa.capacity then
        match list.(n) with
          | Peer p -> add_ask (Ask p) sa; aux (n+1)
          | Empty -> ()
	  | _ -> raise (SlotArray "trying to append non peer")
    in
      aux 0

end 

type peer = {
  id : peer_id;
  mutable con_state : state;
  slots : peer SlotArray.t;
  mutable rounds_data : round_data RoundMap.t;
  messages : message Queue.t;
  mutable history : (int * (int HashMap.t list)) RoundMap.t; (* seed, branch *)
  mutable distance : int;
  mutable connection_time : int;
  mutable nproofs : int
}
and slot = peer SlotArray.slot

let disconnect oc round peer =
  SlotArray.clear peer.slots;
  if (round-peer.connection_time) > 0 then
    Printf.fprintf oc "%d %d %d\n%!" peer.id (round-peer.connection_time)
      peer.nproofs;
  peer.con_state <- OFF;
  peer.distance <- -1;
  peer.nproofs <- 0
    
let swap a pos1 pos2 =
  let temp = a.(pos1) in
    a.(pos1) <- a.(pos2);
    a.(pos2) <- temp
    
let swap_track tracking_array real_array pos1 pos2 =
  let id1 = real_array.(pos1).id in
  let id2 = real_array.(pos2).id in
    swap tracking_array id1 id2;
    swap real_array pos1 pos2
    
let random_iter f a tracking = 
  let rec aux n = match n with
    | 1 -> ()
    | n -> let pos = 1+ Random.int (n-1) in
	swap_track tracking a pos (n-1);
	f a.(n-1);
	aux (n-1)
  in
    aux (Array.length a)