Data::PrioQ::SkewBinomial - A functional priority queue based on skew binomial trees

    use aliased 'Data::PrioQ::SkewBinomial' => 'PQ';

    my $pq = PQ->empty;
    $pq = $pq->insert(1, "foo")->insert(3, "baz")->insert(2, "bar");
    until ($pq->is_empty) {
        ($pq, my ($priority, $data)) = $pq->shift_min;
        print "$priority: $data\n";
    }

    perldoc Data::PrioQ::SkewBinomial

package Data::PrioQ::SkewBinomial;

use warnings; no warnings qw(recursion);
use strict;

use constant {
	ELEM => 0,
	OTHERS => 1,
	CHILDREN => 2,
	RANK => 3,

	KEY => 0,
	VALUE => 1,
	HEAP => 2,

	HEAD => 0,
	TAIL => 1,

	NIL => [],
};

BEGIN {
	*VERSION = \'0.03';

	unless (defined &_DEBUG) {
		*_DEBUG = sub () { 0 };
	}
}

sub _confess {
	require Carp;
	{
		no warnings 'redefine';
		*_confess = \&Carp::confess;
	}
	goto &Carp::confess;
}

sub _assert {
	my ($cond, $name) = @_;
	unless ($cond) {
		@_ = "assertion failed: $name";
		goto &_confess;
	}
}

sub _length {
	my ($xs) = @_;
	my $n = 0;
	while (@$xs) {
		$xs = $xs->[TAIL];
		++$n;
	}
	$n
}

sub _strip_rank {
	my ($t) = @_;
	[@$t[ELEM, OTHERS, CHILDREN]]
}

sub _link {
	my ($t1, $t2) = @_;
	_assert $t1->[RANK] == $t2->[RANK], "trees have equal rank" if _DEBUG;

	$t1->[ELEM][KEY] <= $t2->[ELEM][KEY]
		? [$t1->[ELEM], $t1->[OTHERS], [_strip_rank($t2), $t1->[CHILDREN]], $t1->[RANK] + 1]
		: [$t2->[ELEM], $t2->[OTHERS], [_strip_rank($t1), $t2->[CHILDREN]], $t1->[RANK] + 1]
}

sub _skew_link {
	my ($x, $t1, $t2) = @_;
	my $y = _link $t1, $t2;
	_assert _length($y->[OTHERS]) + 1 <= $y->[RANK], "sufficient space in linked tree" if _DEBUG;
	$x->[KEY] <= $y->[ELEM][KEY]
		? [$x, [$y->[ELEM], $y->[OTHERS]], $y->[CHILDREN], $y->[RANK]]
		: [$y->[ELEM], [$x, $y->[OTHERS]], $y->[CHILDREN], $y->[RANK]]
}

sub _insert {
	my ($ts, $x) = @_;
	@$ts && @{$ts->[TAIL]} && $ts->[HEAD][RANK] == $ts->[TAIL][HEAD][RANK]
		? [_skew_link($x, $ts->[HEAD], $ts->[TAIL][HEAD]), $ts->[TAIL][TAIL]]
		: [[$x, NIL, NIL, 0], $ts]
}

sub _ins_tree {
	my ($t, $ts) = @_;
	while (@$ts && $t->[RANK] >= $ts->[HEAD][RANK]) {
		_assert !@{$ts->[TAIL]} || $ts->[HEAD][RANK] < $ts->[TAIL][HEAD][RANK], "tree ranks are strictly increasing" if _DEBUG;
		$t = _link $t, $ts->[HEAD];
		$ts = $ts->[TAIL];
	}
	[$t, $ts]
}

sub _merge_trees {
	my ($ts1, $ts2) = @_;
	@$ts1 or return $ts2;
	@$ts2 or return $ts1;
	my $t1 = $ts1->[HEAD];
	my $t2 = $ts2->[HEAD];
	my $cmp = $t1->[RANK] <=> $t2->[RANK];
	$cmp < 0 ? [$t1, _merge_trees($ts1->[TAIL], $ts2)] :
	$cmp > 0 ? [$t2, _merge_trees($ts1, $ts2->[TAIL])] :
	_ins_tree _link($t1, $t2), _merge_trees($ts1->[TAIL], $ts2->[TAIL])
}

sub _normalize {
	my ($ts) = @_;
	if (@$ts) {
		my $hd = $ts->[HEAD];
		my $tl = $ts->[TAIL];
		@$tl && $hd->[RANK] == $tl->[HEAD][RANK] and return _ins_tree $hd, $tl;
	}
	$ts
}

sub _merge {
	my ($ts1, $ts2) = @_;
	_merge_trees _normalize($ts1), _normalize($ts2)
}

sub _split {
	my ($ts) = @_;
	my $tl = $ts->[TAIL];
	@$tl or return $ts->[HEAD], $tl;
	my $t1 = $ts->[HEAD];
	my ($t2, $ts2) = _split($tl);
	$t1->[ELEM][KEY] <= $t2->[ELEM][KEY]
		? ($ts->[HEAD], $tl)
		: ($t2, [$t1, $ts2])
}

sub _rev_enrank {
	my ($r, $xs) = @_;
	my $ys = NIL;
	while (@$xs) {
		--$r;
		_assert $r >= 0, "rank $r >= 0" if _DEBUG;
		$ys = [[@{$xs->[HEAD]}, $r], $ys];
		$xs = $xs->[TAIL];
	}
	$ys
}

sub _shift_min {
	my ($pq) = @_;
	my ($t, $ts) = _split $pq;
	my $xs = $t->[OTHERS];
	_assert _length($xs) <= $t->[RANK], "not too many extra nodes in min tree" if _DEBUG;
	my $ys = _merge _rev_enrank($t->[RANK], $t->[CHILDREN]), $ts;
	while (@$xs) {
		$ys = _insert $ys, $xs->[HEAD];
		$xs = $xs->[TAIL];
	}
	$ys, $t->[ELEM]
}

sub _bless {
	my ($self, $x) = @_;
	bless $x, ref $self
}

{
	bless \my @e, __PACKAGE__;
	sub empty {
		\@e
	}
}

sub is_empty {
	my $self = shift;
	!@$self
}

sub _singleton {
	my ($self, $k, $v) = @_;
	$self->_bless([$k, $v, NIL])
}

sub insert {
	my ($self, $k, $v) = @_;
	$self->merge($self->_singleton($k, $v))
}

sub merge {
	my ($self, $other) = @_;
	@$self or return $other;
	@$other or return $self;
	my ($min, $max) = $self->[KEY] <= $other->[KEY] ? ($self, $other) : ($other, $self);
	$self->_bless([@$min[KEY, VALUE], _insert $min->[HEAP], $max])
}

sub peek_min {
	my ($self) = @_;
	@$self
		? ($self->[KEY], $self->[VALUE])
		: ()
}

sub _retfst {
	wantarray ? @_ : $_[0]
}

sub shift_min {
	my ($self) = @_;
	@$self or return _retfst $self, undef, undef;
	@{$self->[HEAP]} or return _retfst ref($self)->empty, @$self[KEY, VALUE];
	my ($h, $other) = _shift_min $self->[HEAP];
	_retfst $self->_bless([@$other[KEY, VALUE], _merge $h, $other->[HEAP]]), @$self[KEY, VALUE]
}

1
__END__