File Coverage

blib/lib/List/MergeSorted/XS.pm

Criterion	Covered	Total	%
statement	86	88	97.7
branch	55	68	80.8
condition	28	41	68.2
subroutine	12	12	100.0
pod	1	1	100.0
total	182	210	86.6

package List::MergeSorted::XS;

use 5.008;
use strict;
use warnings;
use Carp;

require Exporter;
use AutoLoader;

our @ISA = qw(Exporter);

our @EXPORT_OK = qw(merge);
our @EXPORT = qw();

our $VERSION = '1.06';

require XSLoader;
XSLoader::load('List::MergeSorted::XS', $VERSION);

use constant {
    PRIO_LINEAR => 0,
    PRIO_FIB    => 1,
    SORT        => 2,
};

sub merge {
    my $lists = shift;
    my %opts = @_;

    # validate inputs
    unless ($lists && ref $lists && ref $lists eq 'ARRAY') {
        die "merge requires an array reference";
    }
    for my $list (@$lists) {
        unless ($list && ref $list && ref $list eq 'ARRAY') {
            die "lists to merge must be arrayrefs";
        }
    }

    my $limit = $opts{limit} || 0;
    die "limit must be positive" if defined $limit && $limit < 0;

    die "key_cb option must be a coderef"
        if defined $opts{key_cb} && ref $opts{key_cb} ne 'CODE';

    die "uniq_cb option must be a coderef"
        if defined $opts{uniq_cb} && ref $opts{uniq_cb} ne 'CODE';

    return [] unless @$lists;

    # pick an algorithm
    my @params = ($lists, $limit, $opts{key_cb}, $opts{uniq_cb});

    if (defined $opts{method}) {
        return _merge($opts{method}, @params);
    }

    if (defined $opts{key_cb}) {
        # linear priority queue is faster until ~100 lists, relatively
        # independent of limit %. sort never wins in keyed mode because of
        # Schwartzian tx overhead

        return scalar @$lists < 100
            ? _merge(PRIO_LINEAR, @params)
            : _merge(PRIO_FIB, @params);
    }
    else {
        # linear always wins with a small number of lists (<100). with more
        # lists, fib wins with low limit, giving way to sort around 25%
        # limit.

        # compute what fraction of the merged set will be returned
        my $total = _count_elements($lists);
        $limit ||= $total;

        if ($limit < 0.05 * $total) {
            return scalar @$lists < 1000
                ? _merge(PRIO_LINEAR, @params)
                : _merge(PRIO_FIB, @params);
        }
        elsif ($limit < 0.25 * $total) {
            return scalar @$lists < 500
                ? _merge(PRIO_LINEAR, @params)
                : _merge(PRIO_FIB, @params)
        }
        elsif ($limit < 0.75 * $total) {
            return scalar @$lists < 100
                ? _merge(PRIO_LINEAR, @params)
                : _merge(SORT, @params)
        }
        else {
            return scalar @$lists < 100
                ? _merge(PRIO_LINEAR, @params)
                : _merge(SORT, @params)
        }
    }
}

# dispatch to appopriate implementation based on algorithm and options
sub _merge {
    my ($method, $lists, $limit, $key_cb, $uniq_cb) = @_;

    if ($method == PRIO_LINEAR) {
        return $key_cb ? $uniq_cb ? _merge_linear_keyed_dedupe($lists, $limit, $key_cb, $uniq_cb)
                                  : _merge_linear_keyed_dupeok($lists, $limit, $key_cb)
                       : $uniq_cb ? _merge_linear_flat_dedupe($lists, $limit, $uniq_cb)
                                  : _merge_linear_flat_dupeok($lists, $limit);
    }
    elsif ($method == PRIO_FIB) {
        return $key_cb ? $uniq_cb ? _merge_fib_keyed_dedupe($lists, $limit, $key_cb, $uniq_cb)
                                  : _merge_fib_keyed_dupeok($lists, $limit, $key_cb)
                       : $uniq_cb ? _merge_fib_flat_dedupe($lists, $limit, $uniq_cb)
                                  : _merge_fib_flat_dupeok($lists, $limit);
    }
    elsif ($method == SORT) {
        return $key_cb ? $uniq_cb ? _merge_sort_keyed_dedupe($lists, $limit, $key_cb, $uniq_cb)
                                  : _merge_sort_keyed_dupeok($lists, $limit, $key_cb)
                       : $uniq_cb ? _merge_sort_flat_dedupe($lists, $limit, $uniq_cb)
                                  : _merge_sort_flat_dupeok($lists, $limit);
    }
    else {
        die "unknown sort method $method requested\n";
    }
}

# concatenate all lists and sort the whole thing. works well when no limit is
# given.

sub _merge_sort_flat_dupeok {
    my ($lists, $limit) = @_;

    my @output = sort {$a <=> $b} map {@$_} @$lists;
    splice @output, $limit if $limit && @output > $limit;
    return \@output;
}

sub _merge_sort_keyed_dupeok {
    my ($lists, $limit, $keyer) = @_;

    # Schwartzian transform is faster than sorting on
    # {$keyer->($a) <=> # $keyer->($b)}, even for degenerately simple case
    # of $keyer = sub { $_[0] }

    my @output =
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [$keyer->($_), $_] }
        map  { @$_ }
        @$lists;

    splice @output, $limit if $limit && @output > $limit;
    return \@output;
}

sub _merge_sort_flat_dedupe {
    my ($lists, $limit, $uniquer) = @_;

    my @merged = sort {$a <=> $b} map {@$_} @$lists;

    my @output;
    my $last_unique = undef;
    for my $element (@merged) {
        my $unique = $uniquer->($element);
        next if defined $last_unique && $unique == $last_unique;
        push @output, $element;
        $last_unique = $unique;
    }
    splice @output, $limit if $limit && @output > $limit;
    return \@output;
}

sub _merge_sort_keyed_dedupe {
    my ($lists, $limit, $keyer, $uniquer) = @_;

    my @merged =
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [$keyer->($_), $_] }
        map  { @$_ }
        @$lists;

    my @output;
    my %seen;
    for my $element (@merged) {
        my $unique = $uniquer->($element);
        next if $seen{$unique}++;
        push @output, $element;
    }

    splice @output, $limit if $limit && @output > $limit;
    return \@output;
}

1;
__END__