Improve mesh construction.

git-svn-id: https://scm.gforge.inria.fr/svn/pacemaker@27 30fcff6e-8de6-41c7-acce-77ff6d1dd07b

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