File Coverage

blib/lib/Sort/Key/Top/PP.pm

Criterion	Covered	Total	%
statement	92	120	76.6
branch	36	38	94.7
condition	12	12	100.0
subroutine	25	37	67.5
pod	0	24	0.0
total	165	231	71.4

package Sort::Key::Top::PP;

use 5.008;
use strict;
use warnings;
no warnings qw( once );

BEGIN {
	$Sort::Key::Top::PP::AUTHORITY = 'cpan:TOBYINK';
	$Sort::Key::Top::PP::VERSION   = '0.003';
}

use Exporter::Shiny our(@EXPORT) = qw(
	top
	topsort
	keytop
	keytopsort
	ntop
	ntopsort
	nkeytop
	nkeytopsort
	rtop
	rtopsort
	rkeytop
	rkeytopsort
	rntop
	rntopsort
	rnkeytop
	rnkeytopsort
	head
	nhead
	keyhead
	nkeyhead
	tail
	ntail
	keytail
	nkeytail
);

sub _tail_numeric {
	my ($list, $top_n) = @_;
	my @top;
	my $cur;
	for my $i (@$list) {
		next if @top==$top_n && $i->[0] < $top[0][0];
		((@top = $i), next) unless @top;
		my ($low, $high) = (0, scalar @top);
		(
			($cur = ($low + $high) >> 1),
			($i->[0] - $top[$cur][0] > 0)
				? ($low = $cur + 1)
				: ($high = $cur),
		) while $low < $high;
		splice(@top, $low, 0, $i);
		shift @top if @top > $top_n;
	}
	return reverse @top;
}

sub _head_numeric {
	my ($list, $top_n) = @_;
	my @top;
	my $cur;
	for my $i (@$list) {
		next if @top==$top_n && $i->[0] > $top[0][0];
		((@top = $i), next) unless @top;
		my ($low, $high) = (0, scalar @top);
		(
			($cur = ($low + $high) >> 1),
			($top[$cur][0] - $i->[0] > 0)
				? ($low = $cur + 1)
				: ($high = $cur),
		) while $low < $high;
		splice(@top, $low, 0, $i);
		shift @top if @top > $top_n;
	}
	return reverse @top;
}

sub _head_stringy {
	my ($list, $top_n) = @_;
	my @top;
	my $cur;
	for my $i (@$list) {
		next if @top==$top_n && $i->[0] gt $top[0][0];
		((@top = $i), next) unless @top;
		my ($low, $high) = (0, scalar @top);
		(
			($cur = ($low + $high) >> 1),
			(($top[$cur][0] cmp $i->[0]) > 0)
				? ($low = $cur + 1)
				: ($high = $cur),
		) while $low < $high;
		splice(@top, $low, 0, $i);
		shift @top if @top > $top_n;
	}
	return reverse @top;
}

sub _tail_stringy {
	my ($list, $top_n) = @_;
	my @top;
	my $cur;
	for my $i (@$list) {
		next if @top==$top_n && $i->[0] lt $top[0][0];
		((@top = $i), next) unless @top;
		my ($low, $high) = (0, scalar @top);
		(
			($cur = ($low + $high) >> 1),
			(($top[$cur][0] cmp $i->[0]) < 0)
				? ($low = $cur + 1)
				: ($high = $cur),
		) while $low < $high;
		splice(@top, $low, 0, $i);
		shift @top if @top > $top_n;
	}
	return reverse @top;
}

sub _preprocess {
	my $code  = shift;
	my $count = 0;
	$code
		? [ map [ $code->($_), $_, $count++ ], @_ ]
		: [ map [ $_         , $_, $count++ ], @_ ];
}

sub _postprocess {
	my $n = shift;
	wantarray
		? map($_->[1], @_)
		: ( @_ >= $n ? $_[-1][1] : undef )
}

sub _restore_order;
if (eval { require Sort::Key }) {
	*_restore_order = sub { &Sort::Key::ikeysort(sub { $_->[2] }, @_) };
}
else {
	*_restore_order = sub { sort { $a->[2] <=> $b->[2] } @_ };
}

sub top {
	my $n = shift;
	_postprocess $n,
	_restore_order
	_head_stringy(
		_preprocess(undef, @_),
		$n
	);
}

sub topsort {
	my $n = shift;
	_postprocess $n,
	_head_stringy(
		_preprocess(undef, @_),
		$n
	);
}

sub keytop (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_restore_order
	_head_stringy(
		_preprocess($k, @_),
		$n
	);
}

sub keytopsort (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_head_stringy(
		_preprocess($k, @_),
		$n
	);
}

sub ntop {
	my $n = shift;
	_postprocess $n,
	_restore_order
	_head_numeric(
		_preprocess(undef, @_),
		$n
	);
}

sub ntopsort {
	my $n = shift;
	_postprocess $n,
	_head_numeric(
		_preprocess(undef, @_),
		$n
	);
}

sub nkeytop (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_restore_order
	_head_numeric(
		_preprocess($k, @_),
		$n
	);
}

sub nkeytopsort (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_head_numeric(
		_preprocess($k, @_),
		$n
	);
}

sub rtop {
	my $n = shift;
	_postprocess $n,
	_restore_order
	_tail_stringy(
		_preprocess(undef, @_),
		$n
	);
}

sub rtopsort {
	my $n = shift;
	_postprocess $n,
	_tail_stringy(
		_preprocess(undef, @_),
		$n
	);
}

sub rkeytop (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_restore_order
	_tail_stringy(
		_preprocess($k, @_),
		$n
	);
}

sub rkeytopsort (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_tail_stringy(
		_preprocess($k, @_),
		$n
	);
}

sub rntop {
	my $n = shift;
	_postprocess $n,
	_restore_order
	_tail_numeric(
		_preprocess(undef, @_),
		$n
	);
}

sub rntopsort {
	my $n = shift;
	_postprocess $n,
	_tail_numeric(
		_preprocess(undef, @_),
		$n
	);
}

sub rnkeytop (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_restore_order
	_tail_numeric(
		_preprocess($k, @_),
		$n
	);
}

sub rnkeytopsort (&$@) {
	my $k = shift;
	my $n = shift;
	_postprocess $n,
	_tail_numeric(
		_preprocess($k, @_),
		$n
	);
}

sub head {
	unshift @_, 1;
	scalar &topsort;
}

sub nhead {
	unshift @_, 1;
	scalar &ntopsort;
}

sub keyhead (&@) {
	splice(@_, 1, 0, 1);
	scalar &keytopsort;
}

sub nkeyhead (&@) {
	splice(@_, 1, 0, 1);
	scalar &nkeytopsort;
}

sub tail {
	unshift @_, 1;
	scalar &rtopsort;
}

sub ntail {
	unshift @_, 1;
	scalar &rntopsort;
}

sub keytail (&@) {
	splice(@_, 1, 0, 1);
	scalar &rkeytopsort;
}

sub nkeytail (&@) {
	splice(@_, 1, 0, 1);
	scalar &rnkeytopsort;
}

1;

__END__