diff options
| -rw-r--r-- | sources/thibaut/globals.ml | 188 | ||||
| -rw-r--r-- | sources/thibaut/mesh.ml | 9 | ||||
| -rw-r--r-- | sources/thibaut/pacemaker.ml | 1 | ||||
| -rw-r--r-- | sources/thibaut/simulator.ml | 12 |
4 files changed, 107 insertions, 103 deletions
diff --git a/sources/thibaut/globals.ml b/sources/thibaut/globals.ml index f025108..1faf227 100644 --- a/sources/thibaut/globals.ml +++ b/sources/thibaut/globals.ml @@ -32,6 +32,7 @@ module RoundMap : sig val truncate : int -> 'a t -> 'a t end = struct + type 'a t = (int* 'a) list let add round data map = (round,data)::map @@ -75,6 +76,20 @@ end = struct end +let random_iter f a = + let rec aux n = match n with + | 1 -> () + | n -> let pos = 1+ Random.int (n-1) in + let b = a.(pos) in + a.(pos) <- a.(n-1); + a.(n-1) <- b; + f a.(n-1); + aux (n-1) + in + f a.(0); + aux (Array.length a) + + type message_content = | Seed of int * int (* seed, duration *) | SeedReply of int (* hash *) @@ -96,110 +111,91 @@ type round_data = { } module SlotArray : sig - - type 'a t - val length : 'a t -> int - val make : int -> 'a -> 'a t - val full : 'a t -> bool - val add : 'a t -> 'a -> unit - val remove : 'a t -> int -> 'a -> unit - val random_peer : 'a t -> 'a - val clear : 'a t -> 'a -> unit - val map : ('a -> 'a) -> 'a t -> unit - val mapi : (int -> 'a -> 'a option) -> 'a t -> unit - val iter : ('a -> unit) -> 'a t -> unit - val iteri : (int -> 'a -> unit) -> 'a t -> unit - val mem : ('a -> bool) -> 'a t -> bool - + type 'a slot = Peer of 'a | Ask of 'a | AskRoot + 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 + end = struct + + type 'a slot = Peer of 'a | Ask of 'a | AskRoot + + type 'a t = { + mutable npeers : int; + mutable nasks : int; + mutable peers: ('a slot) list; + capacity: int; + mutable asks: ('a slot) list + } + + let full sa = ( sa.npeers = sa.capacity ) + + let iter_asks f sa = + let rec aux result peers asks = match asks with + | [] -> sa.asks <- result; sa.peers <- peers + | a::b -> + if full sa then begin + sa.asks <- (List.rev_append result asks); + sa.peers <- peers + end + else begin match f a with + | Peer p as e -> sa.npeers <- sa.npeers + 1; + sa.nasks <- sa.nasks - 1; + aux result (e::peers) b + | Ask p as e -> aux (e::result) peers b + | AskRoot -> sa.nasks <- sa.nasks - 1; aux result peers b + end + in + aux [] sa.peers sa.asks + + let check_peers f sa = + let rec aux result peers = match peers with + | [] -> sa.peers <- result + | a::b -> if f a then aux (a::result) b + else begin + sa.npeers <- (sa.npeers - 1); + aux result b + end + in + aux [] sa.peers + + let clear sa = + sa.peers <- []; + sa.npeers <- 0 + + let make capacity = { + peers = []; + asks = []; + nasks = 0; + npeers = 0; + capacity = capacity + } - type 'a t = { - mutable length : int; - array : 'a array; - capacity : int - } - - let full t = (t.length = t.capacity) - - let clear t newelem = - for i = 0 to t.capacity-1 do - t.array.(i) <- newelem - done; - t.length <- 0 - - let make n elem = { - length = 0; - array = Array.make n elem; - capacity = n - } - - let add t p = - let length = t.length in - t.array.(length) <- p; - t.length <- length + 1 - - let remove t pos newelem = - let tab = t.array in - let length = (t.length-1) in - tab.(pos) <- tab.(length); - tab.(length) <- newelem; - t.length <- length - - let length t = t.length - - let map f t = - for i = 0 to t.capacity-1 do - t.array.(i) <- f(t.array.(i)) - done - - let mapi f t = - for i = 0 to t.capacity-1 do - match f i t.array.(i) with - | None -> () - | Some x -> t.array.(i) <- x - done - - let iter f t = - for i = 0 to t.capacity-1 do - f(t.array.(i)) - done - - let iteri f t = - for i = 0 to t.capacity-1 do - f i (t.array.(i)) - done - - let mem pred sa = - let found = ref false in - let i = ref 0 in - while not !found && !i < (sa.capacity-1) do - if pred sa.array.(!i) then begin - found := true; - incr i - end - else begin - incr i - end - done; - !found - - let random_peer t = - let n = Random.int t.length in - t.array.(n) -end + let length sa = sa.npeers + + let test f sa = + let rec aux l = match l with + | [] -> false + | a::b -> (f a)||(aux b) + in + aux sa.peers + + let accept p sa = if not (full sa) then begin + sa.npeers <- sa.npeers + 1; + sa.peers <- (p::sa.peers) + end + +end type peer = { id : peer_id; mutable con_state : state; - slots : slot SlotArray.t; + 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 *) } - -and slot = - | Empty - | Peer of peer - | AskRoot - | AskPeer of peer +and slot = peer SlotArray.slot diff --git a/sources/thibaut/mesh.ml b/sources/thibaut/mesh.ml index ebec0b0..554a851 100644 --- a/sources/thibaut/mesh.ml +++ b/sources/thibaut/mesh.ml @@ -11,12 +11,17 @@ let print_slotarray t = let ask = ref 0 let askroot = ref 0 + +let ask_root root p (* peer is asking to p *) let ask_peer peer p = incr ask; if p.id = 0 then incr askroot; + if not SlotArray.full p.slots then + + if p.id = peer.id then AskRoot else if p.con_state <> ON then @@ -32,12 +37,14 @@ let ask_peer peer p = SlotArray.add p.slots (Peer peer); Peer p end - else match SlotArray.random_peer p.slots with + else match SlotArray.random_elem p.slots with | Peer x -> AskPeer x | _ -> failwith "Something is very wrong.\n" end let do_peer root peer = + + let aux i slot = let aux i slot = match slot with | Empty -> if peer.id = 0 then None else Some AskRoot | AskRoot -> diff --git a/sources/thibaut/pacemaker.ml b/sources/thibaut/pacemaker.ml index e5b54c4..d37ef12 100644 --- a/sources/thibaut/pacemaker.ml +++ b/sources/thibaut/pacemaker.ml @@ -1,4 +1,5 @@ open Globals +open SlotArray let find_reply hash replies = let rec aux n replies = match replies with diff --git a/sources/thibaut/simulator.ml b/sources/thibaut/simulator.ml index 41baad7..3d135a3 100644 --- a/sources/thibaut/simulator.ml +++ b/sources/thibaut/simulator.ml @@ -4,8 +4,8 @@ open Mesh let degree = ref 10 let tpm = ref 3 -let accuracy = ref 30 -let duration = ref 9 +let accuracy = ref 60 +let duration = ref 24 let seed = ref 0 let filename = ref "" @@ -59,18 +59,18 @@ let _ = for i = 0 to (nticks-1) do connected := 0; Pacemaker.messages := 0; - if i mod !accuracy = 0 then begin + if i mod !accuracy = 0 then begin incr round; server_init_seed peers.(0) !round !duration end; if i mod !accuracy = !duration then server_init_pulse peers.(0) !round; - + if i mod !tpm = 0 then begin do_trace_round (i/(!tpm)); end; - + do_server !round peers.(0); let do_peer p = @@ -80,7 +80,7 @@ let _ = incr connected end in - Array.iter do_peer peers; + random_iter do_peer peers; if i mod !tpm = 0 then begin Printf.printf "Minute %d, " (i/(!tpm)); |