comment on

Translated from C (translated from Delphi) ~~by Keith Schwarz~~ and slightly Perlified:

package SmoothSort;
use warnings;
use strict;

my ($q, $r, $p, $b, $c, $r1, $b1, $c1);  # Boo! Globals!
my $A;

sub up   { ($_[0], $_[1]) = ($_[0] + $_[1] + 1, $_[0]) }
sub down { ($_[0], $_[1]) = ($_[1], $_[0] - $_[1] - 1) }

sub sift {
    my $r2;
    my $T = $A->[ my $r0 = $r1 ];
    while ($b1 >= 3) {
        $r2 = $r1 - $b1 + $c1;
        $r2 = $r1 - 1, down($b1, $c1) if $A->[ $r1 - 1 ] > $A->[$r2];
        if ($A->[$r2] <= $T) {
            $b1 = 1;
        } else {
            $A->[$r1] = $A->[$r2];
            $r1 = $r2;
            down($b1, $c1);
        }
    }
    $A->[$r1] = $T if $r1 - $r0;
}

sub trinkle {
    my ($p1, $T) = ($p, $A->[ my $r0 = $r1 ]);
    my ($r2, $r3);
    ($b1, $c1) = ($b, $c);
    while ($p1 > 0) {
        $p1 >>= 1, up($b1, $c1) while !($p1 & 1);
        $r3 = $r1 - $b1;
        if ((1 == $p1) || $A->[$r3] <= $T) {
            $p1 = 0;
        } else {
            $p1--;
            if (1 == $b1) {
                $A->[$r1] = $A->[$r3];
                $r1 = $r3;
            } elsif ($b1 >= 3) {
                $r2 = $r1 - $b1 + $c1;
                if ($A->[ $r1 - 1 ] > $A->[$r2]) {
                    $r2 = $r1 - 1;
                    down($b1, $c1);
                    $p1 <<= 1;
                }
                if ($A->[$r2] <= $A->[$r3]) {
                    $A->[$r1] = $A->[$r3];
                    $r1 = $r3;
                } else {
                    $A->[$r1] = $A->[$r2];
                    $r1 = $r2;
                    down($b1, $c1);
                    $p1 = 0;
                }
            }
        }
    }
    $A->[$r1] = $T if $r0 - $r1;
    sift();
}

sub semitrinkle {
    $r1 = $r - $c;
    if ($A->[$r1] > $A->[$r]) {
        @{$A}[ $r, $r1 ] = @{$A}[ $r1, $r ];
        trinkle();
    }
}

sub smoothsort {
    $A = shift;
    $r = 0;
    $_ = 1 for $q, $p, $b, $c;

    while ($q < @$A) {
        $r1 = $r;
        if (($p & 7) == 3) {
            ($b1, $c1) = ($b, $c);
            sift();
            $p = ($p + 1) >> 2;
            up($b, $c) for 1, 2;
        } elsif (($p & 3) == 1) {
            if ($q + $c < @$A) {
                ($b1, $c1) = ($b, $c);
                sift();
            } else {
                trinkle();
            }
            down($b, $c);
            $p <<= 1;
            down($b, $c), $p <<= 1 while $b > 1;
            $p++;
        }
        $q++;
        $r++;
    }
    $r1 = $r;
    trinkle();

    while ($q > 1) {
        $q--;
        if (1 == $b) {
            $r--;
            $p--;
            $p >>= 1, up($b, $c) while !($p & 1);
        } elsif ($b >= 3) {
            $p--;
            $r -= $b - $c;
            semitrinkle() if $p > 0;
            down($b, $c);
            $p = ($p << 1) + 1;
            $r += $c;
            semitrinkle();
            down($b, $c);
            $p = ($p << 1) + 1;
        }
    }
}

__PACKAGE__
[download]

Testing code:

#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

use Test::More tests => 1;
use List::Util qw{ shuffle };
use SmoothSort;

my @arr = shuffle(1 .. 10000);
say "@arr";
SmoothSort::smoothsort(\@arr);
say "@arr";

is_deeply(\@arr, [ 1 .. 10000 ], 'sorted');
[download]

Update: I pasted the wrong link. I started with the linked page, but in the end, I used Algorithm Implementation on Wikibooks.

لսႽ† ᥲᥒ⚪⟊Ⴙᘓᖇ Ꮅᘓᖇ⎱ Ⴙᥲ𝇋ƙᘓᖇ

In reply to Re: Smoothsort by choroba
in thread Smoothsort by QuillMeantTen

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


Perl-Sensitive Sunglasses
	PerlMonks