Smoothsort

by QuillMeantTen (Friar) on Sep 20, 2015 at 10:30 UTC

Thank you for that implementation, I too am working from keithschwartz webpage's explanation. Would you be so kind though as to give more explicit variable and sub names though? I find your code quite cryptic in this regard.

Re: Smoothsort
by Laurent_R (Canon) on Sep 19, 2015 at 22:38 UTC

Just as a counterexample, this is a Perl implementation of another "exotic" sort algorithm, comb sort (or Dobosiewicz sort), I made almost 3 years ago, essentially for fun, and published at the time on the French version of Wikipedia where it can still be found (https://fr.wikipedia.org/wiki/Tri_%C3%A0_peigne):

sub comb_sort {
  my @v = @_;
  my $max = scalar (@v);
  my $gap = $max;
  while (1) {
     my $swapped = 0;
     $gap = int ($gap / 1.3);
     $gap = 11 if $gap == 10 or $gap == 9; # (Combsort11 optimization)
     $gap = 1 if $gap < 1;
     my $lmax = $max - $gap - 1;
     foreach my $i (0..$lmax) {
          ($v[$i], $v[$i+$gap], $swapped) = ($v[$i+$gap], $v[$i], 1) i
+f $v[$i] > $v[$i+$gap];
     }
     last if $gap == 1 and $swapped == 0;
  }
  return @v;
}
[download]

Between your 220-line code and my 17-line code, which one would you prefer to debug?

And, BTW, my version of comb sort seems to be correct (tested with a number of samples of tens of thousands of values) and behaves fairly well in terms of performance: from my own benchmark, it is slightly faster -(x 1.35) than a pure Perl implementation of merge sort for random input, and much faster (x 20) than quick sort and Shell sort for skewed data (e.g. almost sorted, or almost sorted backward input) leading to 0(n�) worst case performance for those latter algorithms.

by QuillMeantTen (Friar) on Sep 19, 2015 at 22:42 UTC

Well yours of course but my coding loquacity is, I reckon, mostly to be blamed on my lack of wisdom and experience. Hence my coming here and my eagerness to find better and simpler ways to do that implementation

Re: Smoothsort
by QuillMeantTen (Friar) on Sep 19, 2015 at 22:28 UTC

I'm not trying to build a better mouse trap. I do this to train myself at using perl and study the workings of this particular algorithm.

@ Anonymous Monk :I feel that as a Cs student just typing sort and go woooo at the magic is not enough and I have found that re implementing the algorithms I find most interesting is a good way to gain a better understanding.

Re: Smoothsort
by flexvault (Monsignor) on Sep 19, 2015 at 19:17 UTC

Hello QuillMeantTen,

There may be a story behind your 're-invention' of sort, but the core 'sort' routine does quite well with these requirements:

> time perl -e '@ar[$_]=int(rand(1000)) for(0..25); print "List:   @ar
+\n";
@str=sort(@ar);print "Str Cmp: @str\n";
@numr=sort{$a<=>$b} @ar;print "Num Cmp: @numr\n";'
[download]

List:    529 175 516 995 715 296 57 189 999 381 315 612 393 914 716 48
+3 30 58 269 849 180 820 546 20 577 127
Str Cmp: 127 175 180 189 20 269 296 30 315 381 393 483 516 529 546 57 
+577 58 612 715 716 820 849 914 995 999
Num Cmp: 20 30 57 58 127 175 180 189 269 296 315 381 393 483 516 529 5
+46 577 612 715 716 820 849 914 995 999

real    0m0.004s
user    0m0.004s
sys     0m0.000s
[download]

Just wondering...Ed

Regards...Ed

"Well done is better than well said." - Benjamin Franklin

Re: Smoothsort
by poj (Abbot) on Sep 20, 2015 at 20:15 UTC

In add_tree should the second heapify be to $$tree_num_ref-2 the same as the preceding get_start_root ?

($start,$root)=get_start_root($trees_ref,$$tree_num_ref-
+1);
heapify($tab_ref,$$trees_ref[$$tree_num_ref-1],$start);
($start,$root) = get_start_root($trees_ref,$$tree_num_ref-
+2);
heapify($tab_ref,$$trees_ref[$$tree_num_ref-1],$start);
[download]

by QuillMeantTen (Friar) on Sep 21, 2015 at 07:00 UTC

Indeed, Indeed, thanks for spotting it!

Re: Smoothsort
by Anonymous Monk on Sep 19, 2015 at 21:02 UTC

my @sorted = sort {comparator($a,$b)} @unsorted; # fixed.
[download]

Re: Smoothsort
by Tux (Canon) on Sep 21, 2015 at 09:45 UTC

There shall be no else after return/die/croak. Ever!

sub leonardo{
    my $n = shift;
    if($n == 0 || $n == 1){
        return 1;
    }
    else{
        return leonardo($n-2)+leonardo($n-1)+1;
    }
}
[download]

SHould be rewritten to either

sub leonardo {
    my $n = shift;
    $n == 0 || $n == 1 and
        return 1;
    return leonardo ($n - 2) + leonardo ($n - 1) + 1;
    }
[download]

or using a ternary

sub leonardo {
    my $n = shift;
    $n == 0 || $n == 1 ? 1 : leonardo ($n - 2) + leonardo ($n - 1) + 1
+;
    }
[download]

with your personal preference to whitespace and indentation of course.

The else in an if is there to give alternative code in a control flow where the code after the if/else contruct is executed for both branches. As the if branch ends with a return statement, immediatly exiting the routine, the code after if/else is never executed and only written for the else branch making the code harder to read and maintain.

Enjoy, Have FUN! H.Merijn

by QuillMeantTen (Friar) on Sep 21, 2015 at 09:55 UTC

The ternary is really so much more elegant, thanks :D

by Anonymous Monk on Sep 21, 2015 at 09:54 UTC

sub leonardo {
  return 1 if 0==$n or 1==$n;
  return leonardo ($n - 2) + leonardo ($n - 1) + 1;
}
[download]

by Anonymous Monk on Sep 21, 2015 at 13:15 UTC

sub leonardo {
    my $n = shift;
    $n <= 1 || leonardo ($n - 2) + leonardo ($n - 1) + 1
+;
    }
[download]

by Anonymous Monk on Sep 21, 2015 at 09:52 UTC

There shall be no else after return/die/croak. Ever!

sure there shall for it is allowed

Re: Smoothsort
by Anonymous Monk on Sep 20, 2015 at 18:39 UTC

Suggestion: try counting comparisons of your smoothsort vs comparisons made by perl's mergesort when sorting the same data. It might be interesting :)

Re: Smoothsort
by Anonymous Monk on Sep 21, 2015 at 15:28 UTC

"I'm also looking to make this code more readable and easily understandable as well as shorter"

Here's my try at shorter, coding straight from the Wikipedia page.

#!/usr/bin/perl

# http://perlmonks.org/?node_id=1142518
# https://en.wikipedia.org/wiki/Smoothsort

use strict;
use warnings;

my $size = shift // 23;

my (@n, @roots); # Leonardo numbers of heaps, and root indexes
my @leonardo = (1, 1); # https://en.wikipedia.org/wiki/Leonardo_number
push @leonardo, $leonardo[-1] + $leonardo[-2] + 1
  while $leonardo[-1] <= $size; # precompute enough (fake memoize :)

my @original = my @a = map { int rand 10 } 1..$size;
print "start   a @a\n";

for my $root (0..$#a) ############################## grow
  {
  if( @n >= 2 && $n[-2] == $n[-1] + 1 ) # consecutive => make bigger h
+eap
    {
    splice @n, -2, 2, $n[-2] + 1;
    splice @roots, -2, 2, $root;
    }
  else # new heap of size 1
    {
    push @n, @n && $n[-1] == 1 ? 0 : 1;
    push @roots, $root;
    }
  restring( $#n );
  }
print "grown   a @a  n @n\n";

while( @n ) ######################################## shrink
  {
  if( $n[-1] > 1 ) # add two subheaps to string
    {
    push @n, --$n[-1] - 1;
    splice @roots, -1, 0, --$roots[-1] - $leonardo[$n[-1]];
    restring( $#n - 1 );
    restring( $#n );
    }
  else # just remove last size 1 heap
    {
    pop @n;
    pop @roots;
    }
  }
print "answer  a @a  n @n\n";
my @oldsort = sort {$a <=> $b} @original;
"@a" eq "@oldsort" or die "***** not sorted *****";

sub restring
  {
  my ($more, $current) = (1, @_);
  while( $current > 0 and $more )
    {
    my ($root, $stringleftroot) = @roots[ $current, $current - 1 ];
    my $leftval = $a[$stringleftroot];
    if( $more = $leftval > $a[$root] && # test left > current
      ($n[$current] <= 1 or $leftval > $a[$root - 1] &&
        $leftval > $a[$root - 1 - $leonardo[$n[$current]-2]] ) )
      {
      @a[$root, $stringleftroot] = @a[ $stringleftroot, $root]; # swap
      $current--; # and move left
      }
    }
  my ($n, $root) = ( $n[$current], $roots[$current] ); # filter
  while( $n > 1 )
    {
    my $rightroot = $root - 1;
    my $leftroot = $rightroot - $leonardo[$n - 2];
    $a[$leftroot] <= $a[$root] && $a[$rightroot] <= $a[$root] and retu
+rn;
    if( $a[$leftroot] > $a[$rightroot] ) # swap largest child
      {
      @a[$leftroot, $root] = @a[$root, $leftroot];
      ($n, $root) = ($n - 1, $leftroot);;
      }
    else
      {
      @a[$rightroot, $root] = @a[$root, $rightroot];
      ($n, $root) = ($n - 2, $rightroot);;
      }
    }
  }
[download]