From 7748ce703653345b18c5bf20b5261a7fc9efc777 Mon Sep 17 00:00:00 2001 From: thibauth Date: Mon, 6 Jun 2011 15:45:25 +0000 Subject: Plug the trace information into the simulator. git-svn-id: https://scm.gforge.inria.fr/svn/pacemaker@20 30fcff6e-8de6-41c7-acce-77ff6d1dd07b --- sources/thibaut/Makefile | 22 ++- sources/thibaut/gentrace.ml | 3 +- sources/thibaut/globals.ml | 10 ++ sources/thibaut/map.ml | 314 ------------------------------------------- sources/thibaut/map.mli | 194 -------------------------- sources/thibaut/map2.ml | 314 +++++++++++++++++++++++++++++++++++++++++++ sources/thibaut/map2.mli | 194 ++++++++++++++++++++++++++ sources/thibaut/pacemaker.ml | 9 +- sources/thibaut/simulator.ml | 49 +++++-- sources/thibaut/trace.ml | 40 +++--- 10 files changed, 597 insertions(+), 552 deletions(-) create mode 100644 sources/thibaut/globals.ml delete mode 100644 sources/thibaut/map.ml delete mode 100644 sources/thibaut/map.mli create mode 100644 sources/thibaut/map2.ml create mode 100644 sources/thibaut/map2.mli (limited to 'sources') diff --git a/sources/thibaut/Makefile b/sources/thibaut/Makefile index 79583d1..187aa22 100644 --- a/sources/thibaut/Makefile +++ b/sources/thibaut/Makefile @@ -1,13 +1,21 @@ -OCAMLC=ocamlc -OCAMLOPT=ocamlopt -OCAMLDEP=ocamldep +OCAMLC=ocamlc.opt +OCAMLOPT=ocamlopt.opt +OCAMLDEP=ocamldep.opt INCLUDES= OCAMLFLAGS=$(INCLUDES) -SRCS=map.ml simulator.ml trace.ml gentrace.ml pacemaker.ml +SRCS=map2.ml simulator.ml trace.ml gentrace.ml pacemaker.ml globals.ml +BUILDDIR=build +all: gentrace.opt simulator.opt -simulator.opt : simulator.cmx - $(OCAMLOPT) -o simulator $(OCAMLFLAGS) map.cmx pacemaker.cmx simulator.cmx +builddir: + mkdir -p $(BUILDDIR) + +gentrace.opt: builddir gentrace.cmx + $(OCAMLOPT) -o $(BUILDDIR)/gentrace $(OCAMLFLAGS) map2.cmx str.cmxa globals.cmx pacemaker.cmx trace.cmx gentrace.cmx + +simulator.opt : builddir simulator.cmx + $(OCAMLOPT) -o $(BUILDDIR)/simulator $(OCAMLFLAGS) map2.cmx str.cmxa globals.cmx pacemaker.cmx trace.cmx simulator.cmx clean: rm -f *.cm? *.cmx? *.o *~ @@ -24,4 +32,4 @@ depend: $(SRCS) %.cmx : %.ml $(OCAMLOPT) -c $(OCAMLFLAGS) $< --include .depend \ No newline at end of file +-include .depend diff --git a/sources/thibaut/gentrace.ml b/sources/thibaut/gentrace.ml index ea12bf5..ad4734a 100644 --- a/sources/thibaut/gentrace.ml +++ b/sources/thibaut/gentrace.ml @@ -1,4 +1,5 @@ open Trace +open Globals let ndays = ref 0 let npeers = ref 0 @@ -38,7 +39,7 @@ let _ = output oc (Days !ndays) let peers = Array.init !npeers (fun i -> - let avail = Random.float 1. in + let avail = if i = 0 then 1. else Random.float 1. in let init = Random.float 1. in let state = if init < avail then ON else OFF in let session_length = 10 + Random.int 90 in diff --git a/sources/thibaut/globals.ml b/sources/thibaut/globals.ml new file mode 100644 index 0000000..90a5a48 --- /dev/null +++ b/sources/thibaut/globals.ml @@ -0,0 +1,10 @@ +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) diff --git a/sources/thibaut/map.ml b/sources/thibaut/map.ml deleted file mode 100644 index 3d9597a..0000000 --- a/sources/thibaut/map.ml +++ /dev/null @@ -1,314 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -module type OrderedType = - sig - type t - val compare: t -> t -> int - end - -module type S = - sig - type key - type +'a t - val empty: 'a t - val is_empty: 'a t -> bool - val mem: key -> 'a t -> bool - val add: key -> 'a -> 'a t -> 'a t - val singleton: key -> 'a -> 'a t - val remove: key -> 'a t -> 'a t - val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val iter: (key -> 'a -> unit) -> 'a t -> unit - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val for_all: (key -> 'a -> bool) -> 'a t -> bool - val exists: (key -> 'a -> bool) -> 'a t -> bool - val filter: (key -> 'a -> bool) -> 'a t -> 'a t - val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t - val cardinal: 'a t -> int - val bindings: 'a t -> (key * 'a) list - val min_binding: 'a t -> (key * 'a) - val max_binding: 'a t -> (key * 'a) - val choose: 'a t -> (key * 'a) - val split: key -> 'a t -> 'a t * 'a option * 'a t - val find: key -> 'a t -> 'a - val map: ('a -> 'b) -> 'a t -> 'b t - val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t - end - -module Make(Ord: OrderedType) = struct - - type key = Ord.t - - type 'a t = - Empty - | Node of 'a t * key * 'a * 'a t * int - - let height = function - Empty -> 0 - | Node(_,_,_,_,h) -> h - - let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let singleton x d = Node(Empty, x, d, Empty, 1) - - let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Map.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - create ll lv ld (create lr x d r) - else begin - match lr with - Empty -> invalid_arg "Map.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Map.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - create (create l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Map.bal" - | Node(rll, rlv, rld, rlr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let empty = Empty - - let is_empty = function Empty -> true | _ -> false - - let rec add x data = function - Empty -> - Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - let c = Ord.compare x v in - if c = 0 then - Node(l, x, data, r, h) - else if c < 0 then - bal (add x data l) v d r - else - bal l v d (add x data r) - - let rec find x = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = Ord.compare x v in - if c = 0 then d - else find x (if c < 0 then l else r) - - let rec mem x = function - Empty -> - false - | Node(l, v, d, r, _) -> - let c = Ord.compare x v in - c = 0 || mem x (if c < 0 then l else r) - - let rec min_binding = function - Empty -> raise Not_found - | Node(Empty, x, d, r, _) -> (x, d) - | Node(l, x, d, r, _) -> min_binding l - - let rec max_binding = function - Empty -> raise Not_found - | Node(l, x, d, Empty, _) -> (x, d) - | Node(l, x, d, r, _) -> max_binding r - - let rec remove_min_binding = function - Empty -> invalid_arg "Map.remove_min_elt" - | Node(Empty, x, d, r, _) -> r - | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r - - let merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (_, _) -> - let (x, d) = min_binding t2 in - bal t1 x d (remove_min_binding t2) - - let rec remove x = function - Empty -> - Empty - | Node(l, v, d, r, h) -> - let c = Ord.compare x v in - if c = 0 then - merge l r - else if c < 0 then - bal (remove x l) v d r - else - bal l v d (remove x r) - - let rec iter f = function - Empty -> () - | Node(l, v, d, r, _) -> - iter f l; f v d; iter f r - - let rec map f = function - Empty -> - Empty - | Node(l, v, d, r, h) -> - let l' = map f l in - let d' = f d in - let r' = map f r in - Node(l', v, d', r', h) - - let rec mapi f = function - Empty -> - Empty - | Node(l, v, d, r, h) -> - let l' = mapi f l in - let d' = f v d in - let r' = mapi f r in - Node(l', v, d', r', h) - - let rec fold f m accu = - match m with - Empty -> accu - | Node(l, v, d, r, _) -> - fold f r (f v d (fold f l accu)) - - let rec for_all p = function - Empty -> true - | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r - - let rec exists p = function - Empty -> false - | Node(l, v, d, r, _) -> p v d || exists p l || exists p r - - let filter p s = - let rec filt accu = function - | Empty -> accu - | Node(l, v, d, r, _) -> - filt (filt (if p v d then add v d accu else accu) l) r in - filt Empty s - - let partition p s = - let rec part (t, f as accu) = function - | Empty -> accu - | Node(l, v, d, r, _) -> - part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in - part (Empty, Empty) s - - (* Same as create and bal, but no assumptions are made on the - relative heights of l and r. *) - - let rec join l v d r = - match (l, r) with - (Empty, _) -> add v d r - | (_, Empty) -> add v d l - | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> - if lh > rh + 2 then bal ll lv ld (join lr v d r) else - if rh > lh + 2 then bal (join l v d rl) rv rd rr else - create l v d r - - (* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. *) - - let concat t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (_, _) -> - let (x, d) = min_binding t2 in - join t1 x d (remove_min_binding t2) - - let concat_or_join t1 v d t2 = - match d with - | Some d -> join t1 v d t2 - | None -> concat t1 t2 - - let rec split x = function - Empty -> - (Empty, None, Empty) - | Node(l, v, d, r, _) -> - let c = Ord.compare x v in - if c = 0 then (l, Some d, r) - else if c < 0 then - let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) - else - let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) - - let rec merge f s1 s2 = - match (s1, s2) with - (Empty, Empty) -> Empty - | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> - let (l2, d2, r2) = split v1 s2 in - concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) - | (_, Node (l2, v2, d2, r2, h2)) -> - let (l1, d1, r1) = split v2 s1 in - concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) - | _ -> - assert false - - type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration - - let rec cons_enum m e = - match m with - Empty -> e - | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) - - let compare cmp m1 m2 = - let rec compare_aux e1 e2 = - match (e1, e2) with - (End, End) -> 0 - | (End, _) -> -1 - | (_, End) -> 1 - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> - let c = Ord.compare v1 v2 in - if c <> 0 then c else - let c = cmp d1 d2 in - if c <> 0 then c else - compare_aux (cons_enum r1 e1) (cons_enum r2 e2) - in compare_aux (cons_enum m1 End) (cons_enum m2 End) - - let equal cmp m1 m2 = - let rec equal_aux e1 e2 = - match (e1, e2) with - (End, End) -> true - | (End, _) -> false - | (_, End) -> false - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> - Ord.compare v1 v2 = 0 && cmp d1 d2 && - equal_aux (cons_enum r1 e1) (cons_enum r2 e2) - in equal_aux (cons_enum m1 End) (cons_enum m2 End) - - let rec cardinal = function - Empty -> 0 - | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r - - let rec bindings_aux accu = function - Empty -> accu - | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l - - let bindings s = - bindings_aux [] s - - let choose = min_binding - -end diff --git a/sources/thibaut/map.mli b/sources/thibaut/map.mli deleted file mode 100644 index b025b8c..0000000 --- a/sources/thibaut/map.mli +++ /dev/null @@ -1,194 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Association tables over ordered types. - - This module implements applicative association tables, also known as - finite maps or dictionaries, given a total ordering function - over the keys. - All operations over maps are purely applicative (no side-effects). - The implementation uses balanced binary trees, and therefore searching - and insertion take time logarithmic in the size of the map. -*) - -module type OrderedType = - sig - type t - (** The type of the map keys. *) - val compare : t -> t -> int - (** A total ordering function over the keys. - This is a two-argument function [f] such that - [f e1 e2] is zero if the keys [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is the generic structural - comparison function {!Pervasives.compare}. *) - end -(** Input signature of the functor {!Map.Make}. *) - -module type S = - sig - type key - (** The type of the map keys. *) - - type (+'a) t - (** The type of maps from type [key] to type ['a]. *) - - val empty: 'a t - (** The empty map. *) - - val is_empty: 'a t -> bool - (** Test whether a map is empty or not. *) - - val mem: key -> 'a t -> bool - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) - - val add: key -> 'a -> 'a t -> 'a t - (** [add x y m] returns a map containing the same bindings as - [m], plus a binding of [x] to [y]. If [x] was already bound - in [m], its previous binding disappears. *) - - val singleton: key -> 'a -> 'a t - (** [singleton x y] returns the one-element map that contains a binding [y] - for [x]. - @since 3.12.0 - *) - - val remove: key -> 'a t -> 'a t - (** [remove x m] returns a map containing the same bindings as - [m], except for [x] which is unbound in the returned map. *) - - val merge: - (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t - (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] - and of [m2]. The presence of each such binding, and the corresponding - value, is determined with the function [f]. - @since 3.12.0 - *) - - val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int - (** Total ordering between maps. The first argument is a total ordering - used to compare data associated with equal keys in the two maps. *) - - val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are - equal, that is, contain equal keys and associate them with - equal data. [cmp] is the equality predicate used to compare - the data associated with the keys. *) - - val iter: (key -> 'a -> unit) -> 'a t -> unit - (** [iter f m] applies [f] to all bindings in map [m]. - [f] receives the key as first argument, and the associated value - as second argument. The bindings are passed to [f] in increasing - order with respect to the ordering over the type of the keys. *) - - val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1 ... kN] are the keys of all bindings in [m] - (in increasing order), and [d1 ... dN] are the associated data. *) - - val for_all: (key -> 'a -> bool) -> 'a t -> bool - (** [for_all p m] checks if all the bindings of the map - satisfy the predicate [p]. - @since 3.12.0 - *) - - val exists: (key -> 'a -> bool) -> 'a t -> bool - (** [exists p m] checks if at least one binding of the map - satisfy the predicate [p]. - @since 3.12.0 - *) - - val filter: (key -> 'a -> bool) -> 'a t -> 'a t - (** [filter p m] returns the map with all the bindings in [m] - that satisfy predicate [p]. - @since 3.12.0 - *) - - val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t - (** [partition p m] returns a pair of maps [(m1, m2)], where - [m1] contains all the bindings of [s] that satisfy the - predicate [p], and [m2] is the map with all the bindings of - [s] that do not satisfy [p]. - @since 3.12.0 - *) - - val cardinal: 'a t -> int - (** Return the number of bindings of a map. - @since 3.12.0 - *) - - val bindings: 'a t -> (key * 'a) list - (** Return the list of all bindings of the given map. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Map.Make}. - @since 3.12.0 - *) - - val min_binding: 'a t -> (key * 'a) - (** Return the smallest binding of the given map - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the map is empty. - @since 3.12.0 - *) - - val max_binding: 'a t -> (key * 'a) - (** Same as {!Map.S.min_binding}, but returns the largest binding - of the given map. - @since 3.12.0 - *) - - val choose: 'a t -> (key * 'a) - (** Return one binding of the given map, or raise [Not_found] if - the map is empty. Which binding is chosen is unspecified, - but equal bindings will be chosen for equal maps. - @since 3.12.0 - *) - - val split: key -> 'a t -> 'a t * 'a option * 'a t - (** [split x m] returns a triple [(l, data, r)], where - [l] is the map with all the bindings of [m] whose key - is strictly less than [x]; - [r] is the map with all the bindings of [m] whose key - is strictly greater than [x]; - [data] is [None] if [m] contains no binding for [x], - or [Some v] if [m] binds [v] to [x]. - @since 3.12.0 - *) - - val find: key -> 'a t -> 'a - (** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. *) - - val map: ('a -> 'b) -> 'a t -> 'b t - (** [map f m] returns a map with same domain as [m], where the - associated value [a] of all bindings of [m] has been - replaced by the result of the application of [f] to [a]. - The bindings are passed to [f] in increasing order - with respect to the ordering over the type of the keys. *) - - val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t - (** Same as {!Map.S.map}, but the function receives as arguments both the - key and the associated value for each binding of the map. *) - - - end -(** Output signature of the functor {!Map.Make}. *) - -module Make (Ord : OrderedType) : S with type key = Ord.t -(** Functor building an implementation of the map structure - given a totally ordered type. *) diff --git a/sources/thibaut/map2.ml b/sources/thibaut/map2.ml new file mode 100644 index 0000000..3d9597a --- /dev/null +++ b/sources/thibaut/map2.ml @@ -0,0 +1,314 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +module type OrderedType = + sig + type t + val compare: t -> t -> int + end + +module type S = + sig + type key + type +'a t + val empty: 'a t + val is_empty: 'a t -> bool + val mem: key -> 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove: key -> 'a t -> 'a t + val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: (key -> 'a -> bool) -> 'a t -> bool + val exists: (key -> 'a -> bool) -> 'a t -> bool + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find: key -> 'a t -> 'a + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + end + +module Make(Ord: OrderedType) = struct + + type key = Ord.t + + type 'a t = + Empty + | Node of 'a t * key * 'a * 'a t * int + + let height = function + Empty -> 0 + | Node(_,_,_,_,h) -> h + + let create l x d r = + let hl = height l and hr = height r in + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + let singleton x d = Node(Empty, x, d, Empty, 1) + + let bal l x d r = + let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Map.bal" + | Node(ll, lv, ld, lr, _) -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match lr with + Empty -> invalid_arg "Map.bal" + | Node(lrl, lrv, lrd, lrr, _)-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Map.bal" + | Node(rl, rv, rd, rr, _) -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match rl with + Empty -> invalid_arg "Map.bal" + | Node(rll, rlv, rld, rlr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let rec add x data = function + Empty -> + Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + let c = Ord.compare x v in + if c = 0 then + Node(l, x, data, r, h) + else if c < 0 then + bal (add x data l) v d r + else + bal l v d (add x data r) + + let rec find x = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + if c = 0 then d + else find x (if c < 0 then l else r) + + let rec mem x = function + Empty -> + false + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + c = 0 || mem x (if c < 0 then l else r) + + let rec min_binding = function + Empty -> raise Not_found + | Node(Empty, x, d, r, _) -> (x, d) + | Node(l, x, d, r, _) -> min_binding l + + let rec max_binding = function + Empty -> raise Not_found + | Node(l, x, d, Empty, _) -> (x, d) + | Node(l, x, d, r, _) -> max_binding r + + let rec remove_min_binding = function + Empty -> invalid_arg "Map.remove_min_elt" + | Node(Empty, x, d, r, _) -> r + | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r + + let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding t2 in + bal t1 x d (remove_min_binding t2) + + let rec remove x = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let c = Ord.compare x v in + if c = 0 then + merge l r + else if c < 0 then + bal (remove x l) v d r + else + bal l v d (remove x r) + + let rec iter f = function + Empty -> () + | Node(l, v, d, r, _) -> + iter f l; f v d; iter f r + + let rec map f = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let l' = map f l in + let d' = f d in + let r' = map f r in + Node(l', v, d', r', h) + + let rec mapi f = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let l' = mapi f l in + let d' = f v d in + let r' = mapi f r in + Node(l', v, d', r', h) + + let rec fold f m accu = + match m with + Empty -> accu + | Node(l, v, d, r, _) -> + fold f r (f v d (fold f l accu)) + + let rec for_all p = function + Empty -> true + | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r + + let rec exists p = function + Empty -> false + | Node(l, v, d, r, _) -> p v d || exists p l || exists p r + + let filter p s = + let rec filt accu = function + | Empty -> accu + | Node(l, v, d, r, _) -> + filt (filt (if p v d then add v d accu else accu) l) r in + filt Empty s + + let partition p s = + let rec part (t, f as accu) = function + | Empty -> accu + | Node(l, v, d, r, _) -> + part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in + part (Empty, Empty) s + + (* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + + let rec join l v d r = + match (l, r) with + (Empty, _) -> add v d r + | (_, Empty) -> add v d l + | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> + if lh > rh + 2 then bal ll lv ld (join lr v d r) else + if rh > lh + 2 then bal (join l v d rl) rv rd rr else + create l v d r + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + + let concat t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding t2 in + join t1 x d (remove_min_binding t2) + + let concat_or_join t1 v d t2 = + match d with + | Some d -> join t1 v d t2 + | None -> concat t1 t2 + + let rec split x = function + Empty -> + (Empty, None, Empty) + | Node(l, v, d, r, _) -> + let c = Ord.compare x v in + if c = 0 then (l, Some d, r) + else if c < 0 then + let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) + else + let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) + + let rec merge f s1 s2 = + match (s1, s2) with + (Empty, Empty) -> Empty + | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> + let (l2, d2, r2) = split v1 s2 in + concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) + | (_, Node (l2, v2, d2, r2, h2)) -> + let (l1, d1, r1) = split v2 s1 in + concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) + | _ -> + assert false + + type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration + + let rec cons_enum m e = + match m with + Empty -> e + | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) + + let compare cmp m1 m2 = + let rec compare_aux e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + let c = Ord.compare v1 v2 in + if c <> 0 then c else + let c = cmp d1 d2 in + if c <> 0 then c else + compare_aux (cons_enum r1 e1) (cons_enum r2 e2) + in compare_aux (cons_enum m1 End) (cons_enum m2 End) + + let equal cmp m1 m2 = + let rec equal_aux e1 e2 = + match (e1, e2) with + (End, End) -> true + | (End, _) -> false + | (_, End) -> false + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + Ord.compare v1 v2 = 0 && cmp d1 d2 && + equal_aux (cons_enum r1 e1) (cons_enum r2 e2) + in equal_aux (cons_enum m1 End) (cons_enum m2 End) + + let rec cardinal = function + Empty -> 0 + | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r + + let rec bindings_aux accu = function + Empty -> accu + | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l + + let bindings s = + bindings_aux [] s + + let choose = min_binding + +end diff --git a/sources/thibaut/map2.mli b/sources/thibaut/map2.mli new file mode 100644 index 0000000..b025b8c --- /dev/null +++ b/sources/thibaut/map2.mli @@ -0,0 +1,194 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Association tables over ordered types. + + This module implements applicative association tables, also known as + finite maps or dictionaries, given a total ordering function + over the keys. + All operations over maps are purely applicative (no side-effects). + The implementation uses balanced binary trees, and therefore searching + and insertion take time logarithmic in the size of the map. +*) + +module type OrderedType = + sig + type t + (** The type of the map keys. *) + val compare : t -> t -> int + (** A total ordering function over the keys. + This is a two-argument function [f] such that + [f e1 e2] is zero if the keys [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is the generic structural + comparison function {!Pervasives.compare}. *) + end +(** Input signature of the functor {!Map.Make}. *) + +module type S = + sig + type key + (** The type of the map keys. *) + + type (+'a) t + (** The type of maps from type [key] to type ['a]. *) + + val empty: 'a t + (** The empty map. *) + + val is_empty: 'a t -> bool + (** Test whether a map is empty or not. *) + + val mem: key -> 'a t -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + val add: key -> 'a -> 'a t -> 'a t + (** [add x y m] returns a map containing the same bindings as + [m], plus a binding of [x] to [y]. If [x] was already bound + in [m], its previous binding disappears. *) + + val singleton: key -> 'a -> 'a t + (** [singleton x y] returns the one-element map that contains a binding [y] + for [x]. + @since 3.12.0 + *) + + val remove: key -> 'a t -> 'a t + (** [remove x m] returns a map containing the same bindings as + [m], except for [x] which is unbound in the returned map. *) + + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + @since 3.12.0 + *) + + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** Total ordering between maps. The first argument is a total ordering + used to compare data associated with equal keys in the two maps. *) + + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + + val iter: (key -> 'a -> unit) -> 'a t -> unit + (** [iter f m] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + + val for_all: (key -> 'a -> bool) -> 'a t -> bool + (** [for_all p m] checks if all the bindings of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + + val exists: (key -> 'a -> bool) -> 'a t -> bool + (** [exists p m] checks if at least one binding of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + (** [filter p m] returns the map with all the bindings in [m] + that satisfy predicate [p]. + @since 3.12.0 + *) + + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + (** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + @since 3.12.0 + *) + + val cardinal: 'a t -> int + (** Return the number of bindings of a map. + @since 3.12.0 + *) + + val bindings: 'a t -> (key * 'a) list + (** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + @since 3.12.0 + *) + + val min_binding: 'a t -> (key * 'a) + (** Return the smallest binding of the given map + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the map is empty. + @since 3.12.0 + *) + + val max_binding: 'a t -> (key * 'a) + (** Same as {!Map.S.min_binding}, but returns the largest binding + of the given map. + @since 3.12.0 + *) + + val choose: 'a t -> (key * 'a) + (** Return one binding of the given map, or raise [Not_found] if + the map is empty. Which binding is chosen is unspecified, + but equal bindings will be chosen for equal maps. + @since 3.12.0 + *) + + val split: key -> 'a t -> 'a t * 'a option * 'a t + (** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + @since 3.12.0 + *) + + val find: key -> 'a t -> 'a + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. *) + + val map: ('a -> 'b) -> 'a t -> 'b t + (** [map f m] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t + (** Same as {!Map.S.map}, but the function receives as arguments both the + key and the associated value for each binding of the map. *) + + + end +(** Output signature of the functor {!Map.Make}. *) + +module Make (Ord : OrderedType) : S with type key = Ord.t +(** Functor building an implementation of the map structure + given a totally ordered type. *) diff --git a/sources/thibaut/pacemaker.ml b/sources/thibaut/pacemaker.ml index 7a26a47..2b85e79 100644 --- a/sources/thibaut/pacemaker.ml +++ b/sources/thibaut/pacemaker.ml @@ -1,5 +1,6 @@ +open Globals + type phase = SEEDING | IDLE -type state = ON | OFF type peer_id = int module PeerId = struct @@ -12,9 +13,9 @@ module Int = struct let compare a b = - (Pervasives.compare a b) end -module HashMap = Map.Make(PeerId) +module HashMap = Map2.Make(PeerId) -module RoundMap = Map.Make(Int) +module RoundMap = Map2.Make(Int) type message_content = | Seed of int * int (* seed, duration *) @@ -177,4 +178,4 @@ let do_server peer = | _ -> () in Queue.iter aux peer.messages; - Queue.clear peer.messages \ No newline at end of file + Queue.clear peer.messages diff --git a/sources/thibaut/simulator.ml b/sources/thibaut/simulator.ml index e097d4d..32855d8 100644 --- a/sources/thibaut/simulator.ml +++ b/sources/thibaut/simulator.ml @@ -1,12 +1,12 @@ open Pacemaker +open Globals -let npeers = ref 0 -let degree = ref 0 -let days = ref 0 -let tpm = ref 0 -let accuracy = ref 0 -let duration = ref 0 +let degree = ref 10 +let tpm = ref 3 +let accuracy = ref 30 +let duration = ref 9 let seed = ref 0 +let filename = ref "" let arg_list = [ "--degree", Arg.Set_int degree, " maximum number of neighbours"; @@ -16,13 +16,30 @@ let arg_list = [ "--seed", Arg.Set_int seed, " random seed" ] +let anon = + let args = ref 0 in + fun s -> + incr args; + match !args with + | 1 -> filename := s + | _ -> raise (Arg.Bad "Too many arguments") + let usage = "usage: simul [OPTIONS] " let _ = - Arg.parse (Arg.align arg_list) (fun s -> ()) usage; - Random.init !seed + if Array.length Sys.argv < 2 then begin + Arg.usage (Arg.align arg_list) usage; + exit 1 + end else begin + Arg.parse (Arg.align arg_list) anon usage; + Random.init !seed + end + +let ic = open_in !filename + +let npeers, days = Trace.read_info ic -let peers = Array.init !npeers (fun i -> { +let peers = Array.init npeers (fun i -> { id = i; con_state = OFF; neighbours = Array.make !degree None; @@ -31,7 +48,9 @@ let peers = Array.init !npeers (fun i -> { history = RoundMap.empty }) -let nticks = (!days)*24*60*(!tpm) +let read_round = Trace.read ic peers npeers + +let nticks = (days)*24*60*(!tpm) let round = ref 0 let _ = @@ -39,12 +58,16 @@ let _ = if i mod !accuracy = 0 then begin incr round; server_init_seed peers.(0) !round !duration - end - else if i mod !accuracy = !duration then + end; + + if i mod !accuracy = !duration then server_init_pulse peers.(0) !round; + if i mod !tpm = 0 then + read_round (i/(!tpm)); + do_server peers.(0); - for i = 1 to (!npeers-1) do + for i = 1 to (npeers-1) do let peer = peers.(i) in if peer.con_state = ON then do_peer peer diff --git a/sources/thibaut/trace.ml b/sources/thibaut/trace.ml index 2ee7c2a..aa74285 100644 --- a/sources/thibaut/trace.ml +++ b/sources/thibaut/trace.ml @@ -1,11 +1,10 @@ -type peer_state = - | ON - | OFF +open Globals +open Pacemaker type event = | Peers of int | Days of int - | Peer of int * float * peer_state + | Peer of int * float * state | Round of int | On of int | Off of int @@ -14,16 +13,12 @@ type event = type peer = { id : int; - mutable state : peer_state; + mutable state : state; avail : float; lambda : float; mu : float } - -let string_of_state state = match state with - | ON -> "On" - | OFF -> "Off" - + let output oc trace_event = let print s = Printf.fprintf oc s in match trace_event with @@ -42,6 +37,9 @@ let input ic = let space = Str.regexp " " in match Str.split space line with | ["Peers"; npeers] -> Peers (int_of_string npeers) + | ["Peer"; id; avail; state] -> Peer (int_of_string id, + float_of_string avail, + state_of_string state) | ["Days"; ndays] -> Days (int_of_string ndays) | ["End"] -> End | ["Round"; round] -> Round (int_of_string round) @@ -49,7 +47,7 @@ let input ic = | ["Off"; i] -> Off (int_of_string i) | _ -> failwith (Printf.sprintf "Bad line [%s]" (String.escaped line)) -let read ic = +let read_info ic = let npeers = match input ic with | Peers n -> n | _ -> failwith "Bad trace" @@ -58,20 +56,24 @@ let read ic = | Days n -> n | _ -> failwith "Bad trace" in - for i = 0 to npeers do + npeers, ndays + +let read ic peers npeers = + for i = 0 to (npeers-1) do match input ic with - | Peer (i, avail, state) -> () + | Peer (i, avail, state) -> peers.(i).con_state <- state | _ -> failwith "Not enough peers" done; + let event = ref (input ic) in let get_event () = event := (input ic) in - let rec read_round round peers = + let rec read_round round = match !event with - | Round n -> if n = round then next round peers - | On i -> peers.(i).Pacemaker.state <- ON; next round peers - | Off i -> peers.(i).Pacemaker.state <- OFF; next round peers + | Round n -> if n = round then next round + | On i -> peers.(i).con_state <- ON; next round + | Off i -> peers.(i).con_state <- OFF; next round | _ -> () - and next round peers = get_event(); read_round round peers in - npeers, ndays, read_round + and next round = get_event(); read_round round in + read_round -- cgit v1.2.3-70-g09d2