package Algorithm::SISort;
require 5.005_62;
use strict;
use warnings;
use Inline C => 'DATA', NAME => 'Algorithm::SISort', VERSION => '0.14';
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(
Sort
Sort_inplace
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw( );
our $VERSION = '0.14';
sub Sort(&@) {
my $callback=shift;
_sort($callback, \@_);
return @_;
}
sub Sort_inplace(&\@) {
my $callback=shift;
return _sort($callback, $_[0]);
}
1;
__DATA__
=head1 NAME
Algorithm::SISort - Select And Insert sorting algorithm
=head1 SYNOPSIS
use Algorithm::SISort qw(Sort Sort_inplace);
@sorted_list = Sort {$_[0] <=> $_[1]} @unsorted_list;
# ... or ...
$number_of_comparisons = Sort_inplace {$_[0] <=> $_[1]} @unsorted_list;
=head1 DESCRIPTION
This module implements a sorting algorithm I saw in BIT 28 (1988) by István
Beck and Stein Krogdahl. This implementation is mainly intended to try out the
Inline module by Brian Ingerson. The algorithm is a combination of I<Straight
Insertion Sort> and I<Selection Sort>. While I<Insertion Sort> and I<Selection
Sort> both are of complexity O(n**2), I<Select and Insert Sort> should have
complexity O(n**1.5).
This module defines the functions C<Sort> and C<Sort_inplace>, which have
signatures similar to the internal C<sort> function. The difference is that a
codref defining a comparison is always required and that the two values to
compare are always passed in C<@_> and not as C<$a> and C<$b>. (Although I
might change that later.)
C<Sort> returns a sorted copy if the array, but C<Sort_inplace> sorts the array
in place (as the name suggests) and returns the number of comparisons done.
(Note that the sorting is always done in place, C<Sort> just copies the array
before calling the internal sort routine.)
=head1 BUGS
Bug-reports are very welcome on the CPAN Request Tracker at:
http://rt.cpan.org/NoAuth/Bugs.html?Dist=Algorithm-SISort
=head1 SEE ALSO
L<Inline>, L<Inline::C>, and I<A Select And Insert Sorting Algorithm> by István
Beck and Stein Krogdahl in I<BIT 28 (1988), 726-735>.
=head1 AUTHOR
Hrafnkell F. Hlodversson, keli@panmedia.dk
=head1 COPYRIGHT
Copyright 2001, Hrafnkell F Hlodversson
All Rights Reserved. This module is free software. It may
be used, redistributed and/or modified under the terms of
the Perl Artistic License.
See http://www.perl.com/perl/misc/Artistic.html
=cut
__C__
static int compare( SV* callback, SV* a, SV* b) {
int retnum,numres;
dSP;
SvREFCNT_inc(a);
SvREFCNT_inc(b);
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(a);
XPUSHs(b);
PUTBACK;
numres=call_sv(SvRV(callback), G_SCALAR);
SPAGAIN;
if(numres==1) {
retnum = POPi;
} else {
retnum = 0;
}
PUTBACK;
FREETMPS;
LEAVE;
return retnum;
}
int _sort (SV* callback, SV* arrayref) {
int n; /* last element of array */
int i, j, step, ncompares;
SV *min, **minp, **A_i, **A_j, **ptr;
AV* A;
if (! SvROK(arrayref))
croak("arrayref is not a reference");
if (! SvROK(callback))
croak("callback is not a reference");
ncompares=0;
A=(AV*)SvRV(arrayref);
n=av_len(A);
for(i=0;i<=n;i++) {
A_i=av_fetch(A,i,0);
min = *A_i;
minp = A_i;
step = 1;
j = i+step;
/* Select a "minimalish" element: */
while ( j <= n ) {
A_j=av_fetch(A,j,0);
ncompares++;
if( compare(callback, *A_j, min ) < 0 ) {
min=*A_j;
minp=A_j;
}
step++;
j+=step;
}
/* Start insertion: */
*minp=*A_i;
j = i-1;
A_j=av_fetch(A,j,0);
while ( j>-1 && compare(callback, *A_j, min ) > 0 ) {
ncompares++;
ptr=av_fetch(A,j+1,0);
*ptr=*A_j;
j--;
A_j=av_fetch(A,j,0);
}
ncompares++;
ptr=av_fetch(A,j+1,0);
*ptr=min;
}
return ncompares;
}