# HG changeset patch
# User David Scott <dave.scott@xxxxxxxxxxxxx>
# Date 1279751355 -3600
# Node ID 542efa53c3e25342a175ead7f9327b972f976820
# Parent  ad151dc6eb4578f098df793e92498a9ba1a9ec3a
Add new modules: lazyList, extentlistSet, set_test to stdext

lazyList contains a simple lazy list implementation.
extentlistSet contains a Set implementation where elements are stored as a list of (start, length) pairs
set_test contains functions to test a set implementation

extentlistset_test contains test cases for extentlistSet using set_test.

Signed-off-by: David Scott <dave.scott@xxxxxxxxxxxxx>

diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/Makefile
--- a/stdext/Makefile	Mon Jul 12 08:33:28 2010 +0100
+++ b/stdext/Makefile	Wed Jul 21 23:29:15 2010 +0100
@@ -22,12 +22,13 @@
 
 STDEXT_OBJS = fun opt listext filenameext stringext arrayext hashtblext pervasiveext threadext ring \
 	qring fring bigbuffer unixext range vIO trie config date encodings fe fecomms \
-	forkhelpers gzip sha1sum zerocheck base64 backtrace tar mapext os either
+	forkhelpers gzip sha1sum zerocheck base64 backtrace tar mapext os either \
+	lazyList extentlistSet set_test
 
 INTF = $(foreach obj, $(STDEXT_OBJS),$(obj).cmi)
 LIBS = stdext.cma stdext.cmxa
 
-PROGRAMS = base64pp fe_cli fe_test
+PROGRAMS = base64pp fe_cli fe_test extentlistset_test
 
 DOCDIR = /myrepos/xen-api-libs.hg/doc
 
@@ -46,6 +47,9 @@
 fe_test: fe_test.ml all libstdext_stubs.a
 	ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) unix.cmxa ../uuid/uuid.cmxa ../rpc-light/rpc.cmx ../rpc-light/jsonrpc.cmx stdext.cmxa -linkpkg -I ../uuid -o $@ $< -ccopt -L.
 
+extentlistset_test: extentlistset_test.ml all libstdext_stubs.a
+	ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) unix.cmxa stdext.cmxa -linkpkg -o $@ $< -ccopt -L.
+
 stdext.cmxa: libstdext_stubs.a $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
 	$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lstdext_stubs $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
 
diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/extentlistSet.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/extentlistSet.ml	Wed Jul 21 23:29:15 2010 +0100
@@ -0,0 +1,106 @@
+
+module type Number = sig
+	type t
+	val zero: t
+	val add : t -> t -> t
+	val sub : t -> t -> t
+end
+
+module ExtentlistSet (A : Number) =
+struct
+	type extent = A.t * A.t
+	type t = extent list
+
+	let ($+) = A.add
+	let ($-) = A.sub
+
+	let empty = []
+
+	let sort list : t =
+		List.sort (fun x y -> compare (fst x) (fst y)) list
+
+	let remove_zeroes = List.filter (fun (_, y) -> y <> A.zero)
+
+	let union (list1: t) (list2: t) : t =
+		let combined = sort (list1 @ list2) in
+		let rec inner l acc =
+			match l with
+				| (s1,e1)::(s2,e2)::ls ->
+					let extent1_end = s1 $+ e1 in
+					if extent1_end < s2 then
+						inner ((s2,e2)::ls) ((s1,e1)::acc)
+					else
+						let extent2_end = s2 $+ e2 in
+						if extent1_end > extent2_end then
+							inner ((s1,e1)::ls) acc
+						else
+							inner ((s1,s2 $+ e2 $- s1)::ls) acc
+				| (s1,e1)::[] -> (s1,e1)::acc
+				| [] -> []
+		in List.rev (inner combined [])
+
+	let intersection (list1: t) (list2: t) =
+		let rec inner l1 l2 acc =
+			match (l1,l2) with
+				| (s1,e1)::l1s , (s2,e2)::l2s ->
+					if s1 > s2 then inner l2 l1 acc else
+						if s1 $+ e1 < s2 then inner l1s l2 acc else
+							if s1 < s2 then inner ((s2,e1 $+ s1 $- s2)::l1s) l2 acc else
+								(* s1=s2 *)
+								if e1 < e2 then
+									inner l1s ((s2 $+ e1,e2 $- e1)::l2s) ((s1,e1)::acc)
+								else if e1 > e2 then
+									inner ((s1 $+ e2,e1 $- e2)::l1s) l2s ((s2,e2)::acc)
+								else (* e1=e2 *)
+									inner l1s l2s ((s1,e1)::acc)
+				| _ -> List.rev acc
+		in
+		remove_zeroes(inner list1 list2 [])
+
+	let difference (list1: t) (list2: t) : t =
+		let rec inner l1 l2 acc =
+			match (l1,l2) with
+				| (s1,e1)::l1s , (s2,e2)::l2s ->
+					if s1<s2 then begin
+						if s1 $+ e1 > s2 then
+							inner ((s2,s1 $+ e1 $- s2)::l1s) l2 ((s1,s2 $- s1)::acc)
+						else
+							inner l1s l2 ((s1,e1)::acc)
+					end else if s1>s2 then begin
+						if s2 $+ e2 > s1 then
+							inner l1 ((s1,s2 $+ e2 $- s1)::l2s) acc
+						else
+							inner l1 l2s acc
+					end else begin
+						(* s1=s2 *)
+						if e1 > e2 then
+							inner ((s1 $+ e2,e1 $- e2)::l1s) l2s acc
+						else if e1 < e2 then
+							inner l1s ((s2 $+ e1,e2 $- e1)::l2s) acc
+						else
+							inner l1s l2s acc
+					end
+				| l1s, [] -> (List.rev acc) @ l1s
+				| [], _ -> List.rev acc
+		in
+		remove_zeroes(inner list1 list2 [])
+
+	let of_list (list: extent list) : t =
+		let l = sort list in
+		let rec inner ls acc =
+			match ls with
+				| (s1,e1)::(s2,e2)::rest ->
+					(* extents should be non-overlapping *)
+					if s1 $+ e1 > s2 then failwith "Bad list"
+					(* adjacent extents should be coalesced *)
+					else if s1 $+ e1=s2 then inner ((s1,e1 $+ e2)::rest) acc
+					else inner ((s2,e2)::rest) ((s1,e1)::acc)
+				| (s1,e1)::[] -> List.rev ((s1,e1)::acc)
+				| [] -> List.rev acc
+		in
+		inner l []
+
+	let fold_left = List.fold_left
+
+	let to_list x = x
+end
diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/extentlistSet.mli
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/extentlistSet.mli	Wed Jul 21 23:29:15 2010 +0100
@@ -0,0 +1,27 @@
+(** A module to represent sets of elements as (start, length) pairs. *)
+
+(** Elements must be 'Numbers': *)
+module type Number = sig 
+	type t 
+	val zero: t
+	val add : t -> t -> t 
+	val sub : t -> t -> t 
+
+end
+
+(** Representation of a Set *)
+module ExtentlistSet: functor (A : Number) -> sig
+	type extent = A.t * A.t
+	type t
+
+	val empty : t
+
+	val union : t -> t -> t
+	val intersection : t -> t -> t
+	val difference : t -> t -> t
+
+	val of_list : extent list -> t
+	val to_list : t -> extent list
+	val fold_left : ('a -> extent -> 'a) -> 'a -> t -> 'a
+end
+
diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/extentlistset_test.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/extentlistset_test.ml	Wed Jul 21 23:29:15 2010 +0100
@@ -0,0 +1,92 @@
+(* We will check if a list of set equalities hold over random inputs *)
+
+open Set_test
+
+(* We test using the integer domain only. *)
+module Intextentlist = ExtentlistSet.ExtentlistSet(struct 
+  type t=int 
+  let zero=0 
+  let add=(+) 
+  let sub=(-) 
+end)
+open Intextentlist
+
+(* Sets are finite, up to cardinality [size] *)
+let size = 1000
+
+module Tests = SetEqualities(struct
+	type t = Intextentlist.t
+	let universe = of_list [(0, size)]
+	let (+) = union
+	let (^) = intersection
+	let (-) = difference
+
+	let not x = universe - x
+	let (=) x y = (x - y = empty) && (y - x = empty)
+	let extent_to_string (s, l) = Printf.sprintf "(%d, %d)" s l
+	let to_string xs = String.concat ", " (List.map extent_to_string (to_list xs))
+end)
+(* Given a triple of inputs, check that all the set equalities hold *)
+let one (a, b, c) = List.iter (fun f -> f a b c) Tests.all
+
+open LazyList
+
+(** [make p s e] return an extentlist starting at [s], ending before [e] where
+    an integer x is covered by the extentlist iff [p x] *)
+let make p s e =
+  let rec ints acc a b = if a < b then ints (a :: acc) (a + 1) b else acc in
+  of_list (List.fold_left (fun acc x -> if p x then (x, 1)::acc else acc) [] (ints [] s e))
+
+(* A lazy-list of random triples (a, b, c)*)
+let random_inputs =	
+  let one () = make (fun _ -> Random.bool ()) 0 (size - 1) in
+  (* Create triples of random inputs for the checker *)
+  let three () = one (), one (), one () in
+  let rec f () = lazy (Cons(three (), f ())) in
+  f ()
+
+let _ = 
+  let n = 1000 in
+  iter (fun _ -> ()) (take n (map one random_inputs));
+  Printf.printf "%d random sets of maximum size %d checked.\n" n size
+
+type run = 
+  | Empty of int
+  | Full of int
+let to_run_list xs = 
+  let rec inner acc index = function
+	| [] -> acc
+	| (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in  let map f xs = 
+	let rec inner acc f = function
+	  | [] -> acc
+	  | (x :: xs) -> inner ((f x)::acc) f xs in
+	  inner [] f xs in
+
+	List.rev (inner [] 0 xs)
+
+let _ =
+  (* vhds have max size of 2 TiB, in 2 MiB blocks => 2**20 blocks *)
+  (* The BAT consists of up to 2**20 blocks in any order *)
+  (* Worst case for us is as many singleton blocks as possible, which *)
+  (* can't be coalesced because they don't have neighbours. The maximum *)
+  (* number of blocks is achieved with the allocation pattern 10101010... *)
+  (* i.e. 2**19 singleton blocks. *)
+
+  (* As a bitmap we would have 2**19 / 2**3 = 2**16 bytes (64kbit) *)
+  let worst_case = make (fun x -> x mod 2 = 1) 0 (1024*1024/2/12) in
+  let hex (a, b) = Printf.sprintf "%x,%x" a b in
+  let to_string xs = "[" ^ (String.concat ";" (Listext.List.map_tr hex xs)) ^ "]" in
+
+
+  Printf.printf "generated\n";
+	let x = to_list worst_case in
+Printf.printf "got a list\n";
+	  let y = Listext.List.map_tr hex x in
+Printf.printf "got lots of strings\n";
+  let s = to_string (to_list worst_case) in
+  Printf.printf "Extent size=%d\n" (String.length s);
+	let string_of_run = function
+	  | Empty x -> Printf.sprintf "-%d" x
+	  | Full x -> Printf.sprintf "+%d" x in
+	let s' = String.concat ";" (Listext.List.map_tr string_of_run (to_run_list x)) in
+	  Printf.printf "Runs size=%d\n" (String.length s')
diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/lazyList.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/lazyList.ml	Wed Jul 21 23:29:15 2010 +0100
@@ -0,0 +1,20 @@
+(* A lazy-list implementation *)
+
+type 'a elt =
+	| Empty
+	| Cons of 'a * 'a t
+and 'a t = 'a elt lazy_t
+
+let rec map f xs = lazy(match Lazy.force xs with
+	| Empty -> Empty
+	| Cons(x, xs) -> Cons(f x, map f xs))
+	
+let rec take n xs = lazy(match n, Lazy.force xs with
+	| 0, _ -> Empty
+	| n, Empty -> raise Not_found
+	| n, Cons(x, xs) -> Cons(x, take (n - 1) xs)) 
+	
+let rec iter f xs = match Lazy.force xs with
+	| Empty -> ()
+	| Cons(x, xs) -> f x; iter f xs
+
diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/lazyList.mli
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/lazyList.mli	Wed Jul 21 23:29:15 2010 +0100
@@ -0,0 +1,16 @@
+(** A lazy-list *)
+
+(** A forced lazy list element *)
+type 'a elt = Empty | Cons of 'a * 'a t
+
+(** A lazy list *)
+and 'a t = 'a elt lazy_t
+
+(** [map f xs] returns the list [f 1; f 2; ...; f n] *)
+val map : ('a -> 'b) -> 'a t -> 'b t
+
+(** [take n xs] returns the list truncated to the first [n] elements *)
+val take : int -> 'a t -> 'a t
+
+(** [iter f xs] applies every list element to [f] *)
+val iter : ('a -> 'b) -> 'a t -> unit
diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/set_test.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/set_test.ml	Wed Jul 21 23:29:15 2010 +0100
@@ -0,0 +1,31 @@
+module type Set = sig
+  type t
+  val (+): t -> t -> t (* union *)
+  val (^): t -> t -> t (* intersection *)
+  val (-): t -> t -> t (* difference *)
+  val not: t -> t      (* complement *)
+  val (=): t -> t -> bool
+
+  val to_string: t -> string
+end
+
+module SetEqualities(S: Set) = struct
+  open S
+
+  let w txt f a b c = 
+	if Pervasives.not(f a b c)
+	then failwith (Printf.sprintf "%s a=%s b=%s c=%s" txt (S.to_string a) (S.to_string b) (S.to_string c))
+	  
+  let all = [
+	w "commutative_1" (fun a b _ -> a + b = b + a);
+	w "commutative_2" (fun a b _ -> a ^ b = b ^ a);
+	w "associative_1" (fun a b c -> (a + b) + c = a + (b + c));
+	w "associative_2" (fun a b c -> (a ^ b) ^ c = a ^ (b ^ c));
+	w "distributive_1" (fun a b c -> a + (b ^ c) = (a + b) ^ (a + c));
+	w "distributive_2" (fun a b c -> a ^ (b + c) = (a ^ b) + (a ^ c));
+	w "complement_1" (fun a _ _ -> not (not a) = a);
+	w "demorgan_1" (fun a b _ -> not (a + b) = (not a) ^ (not b));
+	w "demorgan_2" (fun a b _ -> not (a ^ b) = (not a) + (not b));
+  ]
+end
+
diff -r ad151dc6eb45 -r 542efa53c3e2 stdext/set_test.mli
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/stdext/set_test.mli	Wed Jul 21 23:29:15 2010 +0100
@@ -0,0 +1,15 @@
+module type Set =
+  sig
+    type t
+    val ( + ) : t -> t -> t
+    val ( ^ ) : t -> t -> t
+    val ( - ) : t -> t -> t
+    val not : t -> t
+    val ( = ) : t -> t -> bool
+    val to_string : t -> string
+  end
+module SetEqualities :
+  functor (S : Set) ->
+    sig
+      val all : (S.t -> S.t -> S.t -> unit) list
+    end
diff -r ad151dc6eb45 -r 542efa53c3e2 xapi-libs.spec
--- a/xapi-libs.spec	Mon Jul 12 08:33:28 2010 +0100
+++ b/xapi-libs.spec	Wed Jul 21 23:29:15 2010 +0100
@@ -69,7 +69,7 @@
    /opt/xensource/libexec/pciutil
    /opt/xensource/libexec/sexprpp
    /opt/xensource/libexec/xmlpp
-
+   /opt/xensource/libexec/extentlistset_test
 
 %files devel
 %defattr(-,root,root,-)
@@ -180,6 +180,9 @@
    /usr/lib/ocaml/stdext/dllstdext_stubs.so
    /usr/lib/ocaml/stdext/encodings.cmi
    /usr/lib/ocaml/stdext/encodings.cmx
+   /usr/lib/ocaml/stdext/extentlistSet.cmi
+   /usr/lib/ocaml/stdext/extentlistSet.cmx
+   /usr/lib/ocaml/stdext/extentlistset_test.cmx
    /usr/lib/ocaml/stdext/fe.cmi
    /usr/lib/ocaml/stdext/fe.cmx
    /usr/lib/ocaml/stdext/fecomms.cmi
@@ -197,6 +200,8 @@
    /usr/lib/ocaml/stdext/hashtblext.cmi
    /usr/lib/ocaml/stdext/hashtblext.cmx
    /usr/lib/ocaml/stdext/libstdext_stubs.a
+   /usr/lib/ocaml/stdext/lazyList.cmi
+   /usr/lib/ocaml/stdext/lazyList.cmx
    /usr/lib/ocaml/stdext/listext.cmi
    /usr/lib/ocaml/stdext/listext.cmx
    /usr/lib/ocaml/stdext/mapext.cmi
@@ -211,6 +216,8 @@
    /usr/lib/ocaml/stdext/range.cmx
    /usr/lib/ocaml/stdext/ring.cmi
    /usr/lib/ocaml/stdext/ring.cmx
+   /usr/lib/ocaml/stdext/set_test.cmi
+   /usr/lib/ocaml/stdext/set_test.cmx
    /usr/lib/ocaml/stdext/sha1sum.cmi
    /usr/lib/ocaml/stdext/sha1sum.cmx
    /usr/lib/ocaml/stdext/stdext.a