Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

looking for a Priority Queue

by newatperl (Acolyte)
on May 06, 2002 at 01:47 UTC ( #164204=perlquestion: print w/replies, xml ) Need Help??

newatperl has asked for the wisdom of the Perl Monks concerning the following question:

Before I go and hack a ugly implementation of a priority queue, I just wanted to ask if anyone has seen or can point me to an already implemented version? CPAN has a List::Priority, but this is really (as the module name implies) just a list of elements where elements have some sort of ordering when popped. A real priority queue would allow you to change the priority of any element at any given time, and would allow you to perform any action on the queue (pop, insert, modify_priority) in O(lgn). Thanks.

Replies are listed 'Best First'.
Re: looking for a Priority Queue
by tachyon (Chancellor) on May 06, 2002 at 05:37 UTC

    Interesting task. Here is a quick OO hack that implements what you want. The first couple of lines just demonstrate the data structure.

    Update

    Added a few tests, improved the code, wrote some pod, etc. Here is the updated version. Should make it to cpan in a day or two at Heap::Priority.

    use Data::Dumper; my $q = new Heap::Priority; $q->add($_, int(rand 4)) for 'a'..'j'; print Dumper $q; package Heap::Priority; use Carp; use strict; use vars '$VERSION'; $VERSION = 0.01; sub new { my $class = shift; my $defaults = { '.priorities' => [], '.fifo' => 1, '.highest_first' => 1, '.raise_error' => 0, '.error_message' => '' }; return bless $defaults, $class; } sub fifo { $_[0]->{'.fifo'} = 1 } sub lifo { $_[0]->{'.fifo'} = 0 } sub highest_first { $_[0]->{'.highest_first'} = 1 } sub lowest_first { $_[0]->{'.highest_first'} = 0 } sub raise_error { $_[0]->{'.raise_error'} = shift || 0 } sub add { my ($self, $item, $priority) = @_; $priority ||= 0; unless (defined $item) { $self->error("Need to supply an item to add to heap!\n"); return undef; } push @{$self->{'.items'}->{$item}}, $priority; # we need to re-sort priorities if new priority level supplied wit +h item $self->{'.priorities'} = [ sort { $a <=> $b } ( @{$self->{'.priori +ties'}}, $priority ) ] unless exists $self->{'.heap'}->{$priority}; push @{$self->{'.heap'}->{$priority}}, $item; } sub pop { my $self = shift; my @priorities = @{$self->{'.priorities'}}; return undef unless @priorities; my $priority = $self->{'.highest_first'} ? pop @priorities : shift @priorities; my $item = $self->{'.fifo'} ? shift @{$self->{'.heap'}->{$priority +}}: pop @{$self->{'.heap'}->{$priority +}}; $self->delete_item($item, $priority, 1); return $item; } sub delete_priority_level { my ($self, $priority) = @_; if (exists $self->{'.heap'}->{$priority}) { my @items = @{$self->{'.heap'}->{$priority}}; delete $self->{'.items'}->{$_} for @items; delete $self->{'.heap'}->{$priority}; $self->{'.priorities'} = [ grep { $_ ne $priority } @{$self->{' +.priorities'}} ]; } else { $self->error("Priority level $priority does not exist in heap! +\n"); } } sub delete_item { my ($self, $item, $priority, $_off_heap) = @_; unless (exists $self->{'.items'}->{$item}) { $self->error("Item $item does not exist in heap!\n"); return undef; } if (defined $priority) { # remove item from from appropriate priority level of .heap @{$self->{'.heap'}->{$priority}} = grep{$_ ne $item}@{$self->{ +'.heap'}->{$priority}} unless $_off_heap; # remove item priority level from .items @{$self->{'.items'}->{$item}} = grep {$_ ne $priority} @{$self +->{'.items'}->{$item}}; # remove item if it no longer exists on any priority levels delete $self->{'.items'}->{$item} unless @{$self->{'.items'}-> +{$item}}; # remove priority level if it is now empty as a result or dele +ting item $self->delete_priority_level($priority) unless @{$self->{'.hea +p'}->{$priority}}; } else { for my $priority (@{$self->{'.items'}->{$item}}) { # remove item from from appropriate priority level of .hea +p @{$self->{'.heap'}->{$priority}} = grep{$_ ne $item}@{$sel +f->{'.heap'}->{$priority}}; # remove priority level if empty $self->delete_priority_level($priority) unless @{$self->{' +.heap'}->{$priority}}; } # bye bye item, you are gone delete $self->{'.items'}->{$item}; } } sub modify_priority { my ($self, $item, $priority) = @_; unless (exists $self->{'.items'}->{$item}) { $self->error("Item $item does not exist in heap!\n"); return undef; } $self->delete_item($item); $self->add($item, $priority); } sub get_priority_levels { my $self = shift; my @levels = @{$self->{'.priorities'}}; @levels = reverse @levels if $self->{'.highest_first'}; return wantarray ? @levels : scalar @levels; } sub get_level { my ($self, $priority) = @_; unless (exists $self->{'.heap'}->{$priority}) { $self->error("Priority level $priority does not exist on heap! +\n"); return undef; } my @items = @{$self->{'.heap'}->{$priority}}; @items = reverse @items unless $self->{'.fifo'}; return wantarray ? @items : scalar @items; } sub get_heap { my $self = shift; my @heap = (); my @levels = $self->get_priority_levels(); push @heap, $self->get_level($_) for @levels; return wantarray ? @heap : scalar @heap; } sub error { my ($self, $error) = @_; $self->{'.error_message'} .= $error; croak $self->{'.error_message'} if $self->{'.raise_error'} == 2; carp $self->{'.error_message'} if $self->{'.raise_error'} == 1; } sub err_str { return $_[0]->{'.error_message'} } 1; __END__ =head2 NAME Heap::Priority - Implements a priority queue or stack =head2 SYNOPSIS use Heap::Priority; my $h = new Heap::Priority; $h->add($item,[$priority]); # add an item to the heap $next_item = $h->pop; # get an item back from heap $h->fifo; # set first in first out ie a queue (d +efault) $h->lifo; # set last in first out ie a stack $h->highest_first; # set pop() in high to low priority or +der (default) $h->lowest_first; # set pop() in low to high priority or +der $h->modify_priority($item, $priority); $h->delete_item($item,[$priority]); $h->delete_priority_level($priority); @levels = $h->get_priority_levels; @items = $h->get_level($priority); @all_items = $h->get_heap; $h->raise_error(1); my $error_string = $h->err_str; =head2 DESCRIPTION This module implements a priority queue or stack. The main functions a +re add() and pop() which add and remove from the heap according to the rules yo +u choose. When you add() an item to the heap you can assign a priority l +evel to the item or let the priority level default to 0. What happens when you call pop() depends on the configuration you choo +se. By default the highest priority values will be popped off in first in fir +st out order. fifo() and lifo() set First in First Out and Last In First +Out respectively. highest_first() and lowest_first() allow you to choose t +o pop() the highest priority values first or the lowest priority values first. The internal object model remains constant so you can modify the behav +ior of pop() with impunity during the life of a heap object. modify_priority() allows you to change the priority of a item already +in the heap. A range of other functions are also available to manipulate the heap. =head2 EFFICIENCY The algorithm used in this module is only efficient where the number o +f priority levels is either small in absolute terms or some small fracti +on of the total number of items. Efficiency drops off over a few thousand priority levels. =head2 OBJECT INTERFACE This is an OO module. You begin by creating a new heap object use Heap::Priority; my $h = new Heap::Priority; You then simply call methods on your heap object: $h->add($item, $priority); # add $item with $priority level $h->lifo; # set Last In First Out (ie stack) my $next_item = $h->pop; # get the next item off the heap =head2 METHODS =head3 new() my $h = new Heap::Priority; The constructor takes no arguments and simply returns an empty default + heap. The default configuration is FIFO (ie a queue) with highest integer pr +iority values popped first =head3 add($item,[$priority]) $h->add($item, [$priority]); add() will add $item to the heap. Optionally a an integer $priority le +vel may be assigned (default priority level is 0). =head3 pop() my $next_item = $h->pop; pop() takes no arguments. In default configuration pop() will return those values having the highest integer priority level first in + FIFO order. This behavior can be modified using the methods outlined below. =head3 fifo() $h->fifo; Set pop() to work on a First In First Out basis, otherwise known as a + queue. This is the default configuration. =head3 lifo() $h->lifo; Set pop() to work on a Last In First Out basis, otherwise known as a +stack. =head3 highest_first() $h->highest_first; Set pop() to retrieve items in highest to lowest integer priority orde +r. This is the default configuration. =head3 lowest_first() $h->lowest_first; Set pop() to retrieve items in lowest to highest integer priority orde +r =head3 modify_priority($item,[$priority]) $h->modify_priority($item, $priority); This method allows you to modify the priority of an item in the queue/ +stack. All it actually does is call delete_item($item) and then add($item,$pr +iority) so all the instances of $item in the heap will be removed and replaced + with a single instance of $item at $priority level =head3 delete_item($item,[$priority]) $h->delete_item($item,[$priority]); This method will delete $item from the heap. If the optional $priority is not supplied all instances $item will be removed from the heap. If $priority is supplied then only instances of $item at that priority le +vel will be removed. =head3 delete_priority_level($priority) $h->delete_priority_level($priority); Delete all items of priority level $priority =head3 get_priority_levels() my @levels = $h->get_priority_levels; Returns list of priority levels in current pop() order in list context + and number of priority levels in scalar context =head3 get_level($priority) my @items = $h->get_level($priority); Returns entire priority level in pop() order in list context or number + of items at that level in scalar context =head3 get_heap() my @all_items = $h->get_heap; Returns entire heap in pop() order in list context or total number of +items on heap in scalar context =head3 raise_error($n) $h->raise_error(1); Set error level $n => 2 = croak, 1 = carp, 0 = silent (default) =head3 err_str() $h->err_str; Return error string if any. =head2 EXPORT Nothing: it's an OO module. =head2 BUGS Probably. If you find one let me know... =head2 AUTHOR Dr James Freeman E<lt>jfreeman@tassie.net.auE<gt> =cut

    cheers

    tachyon

    s&&rsenoyhcatreve&&&s&n.+t&"$'$`$\"$\&"&ee&&y&srve&&d&&print

      Thanks tachyon, I could not ask for more.
Re: looking for a Priority Queue
by educated_foo (Vicar) on May 06, 2002 at 03:49 UTC
    You might try Heap::{Binary,Binomial,Fibonacci} on CPAN. The interface will make your gums bleed (i.e. it's Very General with No Sensible Defaults), but will give you what you need.

    /s

    Update: So you wanna use a heap, eh? Here's a comparison between the three Heap::* packages and my homebrew. They're all woefully slow compared to the C++ equivalent. I think the Fibonacci heap will catch up to the others about when the cows come home...

    1000 elements inserted and removed: Rate fib binary simple binomial fib 1.24/s -- -14% -25% -39% binary 1.45/s 17% -- -13% -29% simple 1.67/s 34% 15% -- -18% binomial 2.04/s 64% 41% 22% -- 500: Rate fib binary simple binomial fib 2.62/s -- -18% -29% -36% binary 3.17/s 21% -- -14% -23% simple 3.70/s 41% 17% -- -10% binomial 4.12/s 57% 30% 11% -- 250 elts: Rate fib binary binomial simple fib 5.71/s -- -19% -29% -33% binary 7.07/s 24% -- -13% -17% binomial 8.10/s 42% 15% -- -4% simple 8.47/s 48% 20% 5% --
    /s

    Update 2:So it took a bit of hacking on Inline::CPP to make this work, but here's a comparison for two kinds of priority_queue<SV*>, one calling a perl sub (cheap2), the other doing C comparisons (cheap):

    inserting and removing 500 things: Rate fib binary binomial cheap2 cheap fib 2.63/s -- -17% -35% -76% -98% binary 3.15/s 20% -- -22% -71% -97% binomial 4.02/s 53% 28% -- -63% -96% cheap2 10.8/s 311% 243% 169% -- -90% cheap 110/s 4065% 3374% 2623% 912% -- 1000 things: Rate fib binary binomial cheap2 cheap fib 1.24/s -- -14% -37% -74% -98% binary 1.43/s 16% -- -27% -70% -97% binomial 1.97/s 59% 37% -- -59% -96% cheap2 4.84/s 291% 238% 146% -- -91% cheap 54.8/s 4323% 3723% 2685% 1032% -- 2000: s/iter fib binary binomial cheap2 cheap fib 1.68 -- -9% -39% -73% -98% binary 1.54 9% -- -33% -70% -98% binomial 1.03 63% 49% -- -56% -96% cheap2 0.456 269% 237% 126% -- -92% cheap 3.76e-02 4362% 3977% 2636% 1110% --

      C-- perhaps? Let's test my little perl hack....

      use Priority; my $q = new Priority; my $time = time; $q->add($_,1) for 1..1000000; $q->pop for 1..1000000; print "Did a million in ",time - $time, " seconds"; __DATA__ Did a million in 32 seconds

      That would be 0.032 seconds per thousand....on an old PIII

      cheers

      tachyon

      s&&rsenoyhcatreve&&&s&n.+t&"$'$`$\"$\&"&ee&&y&srve&&d&&print

        This surprises me, since said "little perl hack" sorted the whole list every time anything got inserted. I gues that's actually "++C" though -- Perl's written-in-C quicksort will trounce most clever data structures written in Perl.

        /s

      VGWNSD? That sounds like a keeper.

      -sam

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://164204]
Approved by grep
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (2)
As of 2022-05-21 00:56 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Do you prefer to work remotely?



    Results (76 votes). Check out past polls.

    Notices?