QuickSort in Perl

Question

I tried to implement QuickSort in Perl as I have done in Python and Ruby with the following code:

use strict;
use warnings;

sub sort {
    my ($lista, $p, $r) = @_;
    if ($p < $r) {
        my $q = &partition(\@$lista, $p, $r);
        &sort(\@$lista, $p, $q - 1);
        &sort(\@$lista, $q + 1, $r);
    }
}

sub partition {
    my ($lista, $p, $r) = @_;
    my $x = $$lista[$r];
    my $i = $p - 1;
    for (my $j = $p; $j < @$lista - 1; $j++) {
        if ($$lista[$j] <= $x) {
            $i++;
            ($$lista[$i], $$lista[$j]) = ($$lista[$j], $$lista[$i]);
        }
    }
    ($$lista[$i + 1], $$lista[$r]) = ($$lista[$r], $$lista[$i + 1]);
    return $i + 1;
}

my @lista = (4, 3, 9, 2, 1, 7, 5, 8);
&sort(\@lista, 0, $#lista);
print @lista

In this case the execution falls in an infinite recursion and I don't know why because the code seems to be the same as in Python and Ruby (algorithm from Cormen, An Introduction to Algorithms)

Note: If I try to execute:

my @lista = (3, 2, 1);
&sort(\@lista, 0, $#lista);
print @lista;

The execution ends and the result is correct.

Thanks in advance for your help.

Answer 1

here is a quick one with grep

sub quick_sort {
  my @a = @_;
  return @a if @a < 2;
  my $p = pop @a;
  quick_sort(grep $_ < $p, @a), $p, quick_sort(grep $_ >= $p, @a);
}

Answer 2

use strict;
use warnings;

sub qsort(\@){
    my( $array ) = @_;
    _qsort( $array, 0, @$array - 1 );
}
sub _qsort{
    my( $array, $left, $right ) = @_;
    return $array unless $left < $right;

    my $pivot_index = _qsort_partition( $array, $left, $right );

    _qsort( $array, $left, $pivot_index - 1);
    _qsort( $array, $pivot_index + 1, $right );
}
sub _qsort_partition {
    my ($array, $left, $right) = @_;
    my $pivot_value = $array->[$right];
    my $store_index = $left;

    for my $i ( $left .. ($right-1) ){
        if( $array->[$i] <= $pivot_value ){
            @$array[ $i, $store_index ] = @$array[ $store_index, $i ];
            $store_index++;
        }
    }

    @$array[ $store_index, $right ] = @$array[ $right, $store_index ];
    return $store_index;
}

use JSON 'to_json';
use List::Util 'shuffle';

my @array = 0..9;

my $max_str_len = @array * 2 + 1;
my $format = "%-${max_str_len}s => %-${max_str_len}s\n";

for my $array_length ( @array ){
    my @array = shuffle @array[0..$array_length];

    my $before = to_json \@array;
    qsort( @array );
    my $after = to_json \@array;

    printf $format, $before, $after;
}

example output:

[0]                   => [0]                  
[1,0]                 => [0,1]                
[2,1,0]               => [0,1,2]              
[2,0,1,3]             => [0,1,2,3]            
[2,4,3,0,1]           => [0,1,2,3,4]          
[2,1,3,5,0,4]         => [0,1,2,3,4,5]        
[4,5,2,3,0,6,1]       => [0,1,2,3,4,5,6]      
[1,3,0,7,6,2,5,4]     => [0,1,2,3,4,5,6,7]    
[5,4,3,0,8,2,1,7,6]   => [0,1,2,3,4,5,6,7,8]  
[6,9,8,2,7,3,5,1,0,4] => [0,1,2,3,4,5,6,7,8,9]

Answer 3

Here is a new version of your code, with a corrected algorithm in partition, expanded variable names for readability, and increased usage of Perl idioms:

use strict;
use warnings;

sub qsort (\@) {_qsort($_[0], 0, $#{$_[0]})}

sub _qsort {
    my ($array, $low, $high) = @_;
    if ($low < $high) {
        my $mid = partition($array, $low, $high);
        _qsort($array, $low,     $mid - 1);
        _qsort($array, $mid + 1, $high   );
    }
}

sub partition {
    my ($array, $low, $high) = @_;
    my $x = $$array[$high];
    my $i = $low - 1;
    for my $j ($low .. $high - 1) {
        if ($$array[$j] <= $x) {
            $i++;
            @$array[$i, $j] = @$array[$j, $i];
        }
    }
    $i++;
    @$array[$i, $high] = @$array[$high, $i];
    return $i;
}

my @array = (4, 3, 9, 2, 1, 7, 5, 8);
qsort @array;
print "@array\n"; # 1 2 3 4 5 7 8 9

Since you really don't want to force your caller to always use qsort(@array, 0, $#array) when qsort(@array) will do, the above code makes a qsort wrapper function, that takes a literal array (like the builtin shift @array function) and then calls the three arg _qsort function.

Your exchange implementation is rewritten as an array slice. The leading sigil is changed from $ to @ and a list is placed within the [...] subscript.

Finally, the major problem with your code was that your end condition in partition was wrong. Where you should have used $r, you used $#$lista causing partition to operate on far more of the list than it should. In the code above I have used the for/foreach loop instead of the C-style for(;;){...} loop:

for (my $i = 0; $i <= 100; $i++) {...}

for my $i (0 .. 100) {...} # faster and easier to read

Answer 4

If I understand correctly, $i and $j must never get out of ($p, $r) range in the pratition sub, which does not hold true in your code. Also when you assign something beyond the end of a list, the list will grow and @list-1 will change, and it looks like this is happening here.

Also, a few notes on style:

1) Rename sort to qsort.

2) Call subs w/o the leading &

3) use $list->[$n] instead of $$list[$n] -- that's easier to read.

Answer 5

You are passing the entirety of @$lista by reference to the subs, so the termination condition @$lista - 1 of the for loop in sub partition is probably not doing what you intended.

A stylistic note, \@$lista is redundant, it dereferences the list ref $lista and then takes the reference again, so it's the same as just saying$lista.

For production code it would make more sense to use perl's built in sort function.