]>
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