diff options
Diffstat (limited to 'sources')
| -rw-r--r-- | sources/thibaut/globals.ml | 79 | ||||
| -rw-r--r-- | sources/thibaut/mesh.ml | 98 | ||||
| -rw-r--r-- | sources/thibaut/simulator.ml | 10 | ||||
| -rw-r--r-- | sources/thibaut/trace.ml | 2 |
4 files changed, 115 insertions, 74 deletions
diff --git a/sources/thibaut/globals.ml b/sources/thibaut/globals.ml index 1faf227..08dcb71 100644 --- a/sources/thibaut/globals.ml +++ b/sources/thibaut/globals.ml @@ -86,7 +86,6 @@ let random_iter f a = f a.(n-1); aux (n-1) in - f a.(0); aux (Array.length a) @@ -118,6 +117,17 @@ module SlotArray : sig 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 : int -> 'a t -> ('a slot) list + 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 list) -> 'a t -> unit end = struct @@ -137,11 +147,13 @@ end = struct let rec aux result peers asks = match asks with | [] -> sa.asks <- result; sa.peers <- peers | a::b -> - if full sa then begin + if full sa then + begin sa.asks <- (List.rev_append result asks); sa.peers <- peers end - else begin match f a with + 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 @@ -151,14 +163,16 @@ end = struct in aux [] sa.peers sa.asks - let check_peers f sa = + let filter_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 + | 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 @@ -175,6 +189,8 @@ end = struct } let length sa = sa.npeers + let asks sa = sa.nasks + let capacity sa = sa.capacity let test f sa = let rec aux l = match l with @@ -187,7 +203,50 @@ end = struct sa.npeers <- sa.npeers + 1; sa.peers <- (p::sa.peers) end - + + let iter f sa = + let rec aux l = match l with + | [] -> () + | a::b -> f a; aux b + in + aux sa.peers + + let random_peer sa = + let n = Random.int sa.npeers in + let rec aux n peers = match n with + | 0 -> List.hd peers + | n -> aux (n-1) (List.tl peers) + in aux n sa.peers + + let random_peer_avoid pred sa = + if sa.npeers <= 1 then AskRoot + else let n = Random.int (sa.npeers-1) in + let rec aux n peers = match n with + | 0 -> begin try List.hd peers with Failure s -> AskRoot end + | n -> if pred (List.hd peers) then aux n (List.tl peers) else aux (n-1) (List.tl peers) + in + aux n sa.peers + + let ask_list n sa = + let rec aux n result peers = match n with + | 0 -> result + | n -> + begin match peers with + | [] -> result + | a::b -> let Peer p = a in aux (n-1) ((Ask p)::result) b + end + in + aux n [] sa.peers + + let append_asks list sa = + let rec aux n result arg = match arg with + | [] -> n, result + | a::b -> aux (n+1) (a::result) b + in + let n, result = aux 0 sa.asks list in + sa.nasks <- sa.nasks + n; + sa.asks <- result + end type peer = { diff --git a/sources/thibaut/mesh.ml b/sources/thibaut/mesh.ml index 554a851..64fafad 100644 --- a/sources/thibaut/mesh.ml +++ b/sources/thibaut/mesh.ml @@ -1,79 +1,57 @@ open Globals - -let print_slotarray t = - let aux elem = begin match elem with - | Peer p -> print_int p.id - | AskRoot -> print_string "Askroot" - | AskPeer p -> Printf.printf "Ask %d" p.id - | Empty -> print_string "Empty" - end; print_char ',' in - SlotArray.iter aux t - +open Globals.SlotArray let ask = ref 0 let askroot = ref 0 -let ask_root root p +let equal a b = match a with + | Peer x -> let Peer y = b in x.id = y.id + | _ -> false + +(* p is asking n slots to root *) +let ask_root root p n = + incr askroot; + if not (SlotArray.full root.slots) then begin + SlotArray.accept (Peer p) root.slots; + true, SlotArray.ask_list (n-1) root.slots + end + else + false, SlotArray.ask_list n root.slots + (* 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 + if p.id = peer.id then AskRoot else if p.con_state <> ON then AskRoot else begin - let pred elem = match elem with - | Peer x -> x.id = peer.id - | _ -> false - in - if SlotArray.mem pred p.slots then - AskRoot + if SlotArray.test (equal (Peer peer)) p.slots then + SlotArray.random_peer_avoid (equal (Peer peer)) p.slots else if not (SlotArray.full p.slots) then begin - SlotArray.add p.slots (Peer peer); + SlotArray.accept (Peer peer) p.slots; Peer p end - else match SlotArray.random_elem p.slots with - | Peer x -> AskPeer x + else match SlotArray.random_peer p.slots with + | Peer x -> Ask 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 -> - begin match ask_peer peer root with - | Peer p -> - if p.con_state = ON then begin - SlotArray.add peer.slots (Peer p); - None - end - else - Some AskRoot - | x -> Some x - end - | AskPeer p -> - begin match ask_peer peer p with - | Peer p -> - if p.con_state = ON then begin - SlotArray.add peer.slots (Peer p); - None - end - else - Some AskRoot - | x -> Some x - end - | Peer p -> - if p.con_state = ON then None - else begin - SlotArray.remove peer.slots i Empty; - None - end - in - SlotArray.mapi aux peer.slots + let aux a = let Ask p = a in ask_peer peer p in + SlotArray.filter_peers (fun (Peer p) -> p.con_state = ON) peer.slots; + SlotArray.iter_asks aux peer.slots; + let free_slots = SlotArray.capacity peer.slots - SlotArray.length peer.slots + - SlotArray.asks peer.slots in + if free_slots > 0 then + let (a,b) = ask_root root peer free_slots in + if a then begin + SlotArray.accept (Peer root) peer.slots; + SlotArray.append_asks b peer.slots + end + else + SlotArray.append_asks b peer.slots + +let do_server root = + SlotArray.filter_peers (fun (Peer p) -> p.con_state = ON) root.slots + diff --git a/sources/thibaut/simulator.ml b/sources/thibaut/simulator.ml index 3d135a3..d738214 100644 --- a/sources/thibaut/simulator.ml +++ b/sources/thibaut/simulator.ml @@ -43,7 +43,7 @@ let npeers, days = Trace.read_info ic let peers = Array.init npeers (fun i -> { id = i; con_state = OFF; - slots = SlotArray.make !degree Empty; + slots = SlotArray.make !degree; rounds_data = RoundMap.empty; messages = Queue.create(); history = RoundMap.empty @@ -71,12 +71,16 @@ let _ = do_trace_round (i/(!tpm)); end; - do_server !round peers.(0); + let do_server root = + Mesh.do_server root; + Pacemaker.do_server !round root + in + do_server peers.(0); let do_peer p = if p.con_state = ON then begin - Pacemaker.do_peer !round p; Mesh.do_peer peers.(0) p; + Pacemaker.do_peer !round p; incr connected end in diff --git a/sources/thibaut/trace.ml b/sources/thibaut/trace.ml index e284846..627cbe3 100644 --- a/sources/thibaut/trace.ml +++ b/sources/thibaut/trace.ml @@ -70,7 +70,7 @@ let read ic peers = match !event with | Round n -> if n = round then next round | On i -> peers.(i).con_state <- ON; next round - | Off i -> SlotArray.clear peers.(i).slots Empty; + | Off i -> SlotArray.clear peers.(i).slots; peers.(i).con_state <- OFF; next round | _ -> () |