File Coverage

blib/lib/List/GroupingPriorityQueue.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	22	22	100.0
condition			n/a
subroutine	16	16	100.0
pod	12	12	100.0
total	127	127	100.0

# -*- Perl -*-
#
# based on List::PriorityQueue execpt that payloads with identical
# priorities are grouped together

package List::GroupingPriorityQueue;

use 5.6.0;
use strict;
use warnings;
our $VERSION = '0.01';

use parent qw(Exporter);
our @EXPORT_OK =
  qw(grpriq_add grpriq_min grpriq_min_values grpriq_max grpriq_max_values);

########################################################################
#
# FUNCTIONS

sub grpriq_add {
    my ( $qref, $priority, @rest ) = @_;
    # special cases
    unless (@$qref) {
        @$qref = [ [@rest], $priority ];
        return;
    }
    if ( $priority > $qref->[-1][1] ) {
        push @$qref, [ [@rest], $priority ];
        return;
    }
    if ( $priority < $qref->[0][1] ) {
        unshift @$qref, [ [@rest], $priority ];
        return;
    }
    if ( $priority == $qref->[-1][1] ) {
        push @{ $qref->[-1][0] }, @rest;
        return;
    }
    if ( $priority == $qref->[0][1] ) {
        push @{ $qref->[0][0] }, @rest;
        return;
    }
    my $lower = 0;
    my $midpoint;
    my $upper = $#$qref;
    while ( $lower <= $upper ) {
        $midpoint = ( $lower + $upper ) >> 1;
        if ( $priority < $qref->[$midpoint][1] ) {
            $upper = $midpoint - 1;
            next;
        }
        if ( $priority > $qref->[$midpoint][1] ) {
            $lower = $midpoint + 1;
            next;
        }
        push @{ $qref->[$midpoint][0] }, @rest;
        return;
    }
    splice @$qref, $lower, 0, [ [@rest], $priority ];
    return;
}

sub grpriq_min { shift @{ $_[0] } }

sub grpriq_min_values {
    my $ref = shift @{ $_[0] };
    return unless defined $ref;
    $ref->[0];
}

sub grpriq_max { pop @{ $_[0] } }

sub grpriq_max_values {
    my $ref = pop @{ $_[0] };
    return unless defined $ref;
    $ref->[0];
}

########################################################################
#
# METHODS

sub each {
    my ( $self, $callback ) = @_;
    while ( my $entry = shift @{ $self->{queue} } ) {
        $callback->(@$entry);
    }
}

sub new { bless { queue => [] }, $_[0] }

sub insert {
    my ( $self, $priority, @rest ) = @_;
    grpriq_add( $self->{queue}, $priority, @rest );
    return $self;
}

sub min { shift @{ $_[0]->{queue} } }

sub min_values {
    my $ref = shift @{ $_[0]->{queue} };
    return unless defined $ref;
    $ref->[0];
}
*pop = \&min_values;

sub max { pop @{ $_[0]->{queue} } }

sub max_values {
    my $ref = pop @{ $_[0]->{queue} };
    return unless defined $ref;
    $ref->[0];
}

1;
__END__