Re: [Caml-list] Sorted list

[Brian Hurt <bhurt@spnz.org>]

On Sat, 4 Aug 2007, tmp123@menta.net wrote:

> Hello,
>
> In order to implement a timers subsystem, I need a module with the following 
> values:
>
> *) add_timer : time -> ( unit -> unit ) -> timerid,
> for public usage, where "add_timer t f" means execute "f" at time "t".  The 
> result is an identifier who allows cancelation of the timer.
> *) cancel_timer: timerid -> unit
> for public usage, cancel a previously added timer
> *) peek_minimum_timer : unit -> ( time, unit -> unit )
> for internal usage, get the timer with minimum time. Returns the time and the 
> related function.
> *) remove_minimum_timer : ?? -> unit
> for internal usage, remove the timer with the minimum time. It will be called 
> after execute a timer.
>
> Thus, in a generic sense, what I need is a "sorted list", with easy insertion 
> of elements, and peek/pop of the head (minimum).
>
> Of the standard modules, the most similar seems "set", because allows 
> insertion and has the funcion "min_elt". However, the problem is, if two 
> timers have the same time, addition of the second one removes the first.
>
> Please, has someone any sugestion?

What you want is a priority queue.

Here's a simple one: a leftist priority queue.  The core operation is 
join, which takes two priority queues and joins them together:

module type Req = sig
 	type t
 	val compare : t -> t -> int
end

module Make(Ord: Req) = struct

type elem = Ord.t;;

type t =
 	| Node of int * t * Ord.t * t
 	| Empty
;;

let height = function
 	| Empty -> 0
 	| Node(h, _, _, _) -> h
;;

let join p q =
 	match p, q with
 	| Empty, Empty -> Empty
 	| Empty, _ -> q
 	| _, Empty -> p
 	| Node(_, pl, px, pr), Node(_, ql, qx, qr) ->
 		let x, l, m, r =
 			if (Ord.compare px qx) <= 0 then
 				px, pl, pr, q
 			else
 				qx, p ql, qr
 		in
 		(* pick the tallest of l, m, and r to be the new left
 		 * node.  The new right node is the join of the remaining
 		 * two nodes.
 		 *)
 		let left, right =
 			if (height l) >= (height m) then
 				if (height l) >= (height r) then
 					l, (join m r)
 				else
 					r, (join l m)
 			else
 				if (height m) >= (height r) then
 					m, (join l r)
 				else
 					r, (join l m)
 		in
 		let h = 1 + (max (height left) (height right)) in
 		Node(h, left, x, right)
;;

let empty = Empty;;

let singelton x = Node(1, Empty, x, Empty);;

let is_empty = function
 	| Empty -> true
 	| Node(_, _, _, _) -> false
;;

let get_head = function
 	| Empty -> invalid_arg "head on empty priority queue!"
 	| Node(_, _, x, _) -> x
;;

let remove_head = function
 	| Empty -> invalid_arg "remove_head on empty priority queue!"
 	| Node(_, l, _, r) -> join l r
;;

let add q x =
 	let p = singleton x in
 	join q p
;;

let rec filter f = function
 	| Empty -> Empty
 	| Node(_, l, x, r) ->
 		if f x then
 			join (join (filter l) (singleton x)) (filter r)
 		else
 			join (filter l) (filter r)
;;

The one problem with this is that filter is O(N log N).  I'd probably just 
add a bit of mutable data to the timer structure, a boolean flag to say 
wether it's been deleted our not.  Then, when you remove the head node, 
you keep removing the head node while it's been deleted (i.e. a deleted 
node doesn't get removed until it times out).  If the number of deleted 
nodes reaches some sufficiently high percentage, you can then afford to 
filter the whole table and delete all of them at once.

Brian