http://qs321.pair.com?node_id=1142518

QuillMeantTen has asked for the wisdom of the Perl Monks concerning the following question:

greetings,
Last year after I discovered smoothsort I thought about making it my fetish sorting algorithm.
After breaking my teeth on it for a while I dumped it in favor of introsort.

Three days ago I decided to get back at it.

UPDATE: thanks to Athanasius, I set up to reworking all my for loops and found out where the error occured, it was a silly mistake having to do with parenthesis placement :

when working on the heapify function (I started there because it seemed most logical that the loss of the max heap status occured because of something occuring there)
I found out the following : instead of giving the right position as $start+leonardo($order)-1 as position for root I gave $start+leonardo($order-1)

This mistake created an error that could go unnoticed with small enough trees but would grow quite fast as tree size would grow.

I also made some refactoring to make the code more readable (mainly using hashs instead of those pesky chained dereference.
I post the code here at the top, the old flawed code can be found at the bottom. Thanks for the help guys, I'm also looking to make this code more readable and easily understandable as well as shorter so it can be used to explain in a perl way (rather than keithschwartz's c++ way) how to make an unoptimized smoothsort.

Update's Update : added some new lines to prevent eyes from bleeding and the following link th the CUFP smoothsort post

#!/usr/bin/perl use strict; use warnings; use Memoize; memoize('leonardo'); sub leonardo{ my $n = shift; $n == 0 || $n == 1?1:leonardo($n-2)+leonardo($n-1)+1; } sub heapify{ #this function operates on only one tree, given its order and star +t #it will make sure its a heap my($tab_ref,$order,$start) = @_; my $move = 0; #if the tree order is 0 or 1 then its a one element tree, so #its already sorted if($order > 1){ my %father = (value=>$tab_ref->[$start+leonardo($order)-1], pos=>$start+leonardo($order)-1); my %left_child = (value =>$tab_ref->[$start+leonardo($order-1) +-1], pos=>$start+leonardo($order-1)-1); my %right_child = (value=>$tab_ref->[$start+leonardo($order)-2 +], pos=>$start+leonardo($order)-2); #is left child bigger than father? #if yes swap them if($left_child{value} > $father{value}){ $tab_ref->[$father{pos}] = $left_child{value}; $tab_ref->[$left_child{pos}] = $father{value}; $move++; } #is right child bigger than father? if yes swap them elsif ( $right_child{value} > $father{value}){ $tab_ref->[$father{pos}] = $right_child{value}; $tab_ref->[$right_child{pos}] = $father{value}; $move++; } #now lets do a recursion into the left child if it is more tha +n one #node if($order -1 > 1){ heapify($tab_ref,$order-1,$start); } #now lets do a recursion into the right child if it is more th +an one #node if($order-2 > 1){ heapify($tab_ref,$order-2,$start+leonardo($order-1)); } if($move > 0){ #lets reheapify myself in case something percolated up heapify($tab_ref,$order,$start); } } } sub restring{ my($tab_ref,$trees_ref,$treenum) = @_; my @roots; my ($start,$root) = (0,0); #I create an array containing the indices of all tree roots for my $i ( 0..$treenum-1){ ($start,$root) = get_start_root($trees_ref,$i); $roots[$i] = $root; } my $move = 0; #now for each tree root I make sure its bigger than its predecesso +r for my $i ( 0 .. $#roots){ my %cur = (pos=>$roots[$i],value=>$tab_ref->[$roots[$i]]); #if I'm checking the first root, the predecessor is himself my %prev = $i > 0?(pos=>$roots[$i-1],value=>$tab_ref->[$roots[ +$i-1]]):%cur; #if the current root is lower than its predecessor I swap them #then make sure the heap property of both is still ok if($cur{value}<$prev{value}){ $tab_ref->[$cur{pos}] = $prev{value}; $tab_ref->[$prev{pos}] = $cur{value}; $move++; ($start,$root) = get_start_root($trees_ref,$i); heapify($tab_ref,$$trees_ref[$i],$start); ($start,$root) = get_start_root($trees_ref,$i-1); heapify($tab_ref,$$trees_ref[$i-1],$start); } } #if I made any move, the heapify function might have crapped up my #stringing, hence I recurse to make sure everything is ok if($move > 0){ restring($tab_ref,$trees_ref,$treenum); } } sub add_tree{ my($trees_ref,$tree_num_ref,$tab_ref) = @_; my ($start,$root); #if last two treers are of continuous orders if($$trees_ref[$$tree_num_ref-1] == $$trees_ref[$$tree_num_ref-2]- +1){ $$trees_ref[$$tree_num_ref-1]."\n"; $$trees_ref[$$tree_num_ref-2]++; $$tree_num_ref--; ($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); restring($tab_ref,$trees_ref,$$tree_num_ref); } #if last tree is not of order 1 I create one elsif($$trees_ref[$$tree_num_ref-1] != 1){ $$trees_ref[$$tree_num_ref] = 1; $$tree_num_ref++; ($start,$root) = get_start_root($trees_ref,$$tree_num_ref- +1); heapify($tab_ref,$$trees_ref[$$tree_num_ref-1],$start); restring($tab_ref,$trees_ref,$$tree_num_ref); } #else I create a tree of order 0 else{ $$trees_ref[$$tree_num_ref] = 0; $$tree_num_ref++; ($start,$root) = get_start_root($trees_ref,$$tree_num_ref- +1); heapify($tab_ref,$$trees_ref[$$tree_num_ref-1],$start); restring($tab_ref,$trees_ref,$$tree_num_ref); } } sub smoothsort{ my $tab_ref = shift; my @trees; my $trees_ref = \@trees; my $treenum = 0; #I have more than one value, so I initiate with two trees of l0 an +d l1 if($#$tab_ref > 0){ $$trees_ref[0] = 1; $$trees_ref[1] = 0; $treenum +=2; } #I have only one value else{ $$trees_ref[0] = 0; $treenum++; } my($start,$root); restring($tab_ref,$trees_ref,$treenum); my $cur = 2; while($cur < $#$tab_ref+1){ add_tree($trees_ref,\$treenum,$tab_ref); $cur++; } #now that I'm done tree building and stringing I can start to dequ +eue: #starting from the last tree while($treenum > 0){ my $cur_tree = $$trees_ref[$treenum-1]; ($start,$root)=get_start_root($trees_ref,$treenum-1); if($cur_tree > 1){ #this tree has children, hence it is broken up in two subt +rees #the first is of the same order minus one takes the place +of #its father, the second one of same order minus two is add +ed $$trees_ref[$treenum] = $$trees_ref[$treenum-1]-2; $$trees_ref[$treenum-1] -= 1; $treenum++; ($start,$root) = get_start_root($trees_ref,$treenum-1); restring($tab_ref,$trees_ref,$treenum); heapify($tab_ref,$$trees_ref[$treenum-1],$start); ($start,$root) = get_start_root($trees_ref,$treenum-2); heapify($tab_ref,$$trees_ref[$treenum-2],$start); } else{ $treenum--; } } } sub get_start_root{ my ($trees_ref,$tree_ind) = @_; my ($start,$root) = (0,0); #if it is the first tree, then its start indice is 0 if($tree_ind > 0){ for my $i ( 0 .. $tree_ind-1){ $start += leonardo($$trees_ref[$i]); } } $root = $start + leonardo($$trees_ref[$tree_ind])-1; return ($start,$root); } my $n = $ARGV[0]; my @tab; for(my $i = 0; $i < $n;$i++){ $tab[$i] = int(rand(1000)); } print "unsorted tab = @tab\n"; smoothsort(\@tab); print "sorted tab = @tab\n"

So here is a flawed implementation : it works for arrays up to a size of 9 but after I start getting misplaced values. I would love some help, for I feel close to my goal and yet I am thwarted.

#!/usr/bin/perl use strict; use warnings; sub leonardo{ my $n = shift; if($n == 0 || $n == 1){ return 1; } else{ return leonardo($n-2)+leonardo($n-1)+1; } } sub heapify{ #this function operates on only one tree, given its order and star +t #it will make sure its a heap my($tab_ref,$order,$start) = @_; printf("going to heapify:\n"); for(my $i = $start; $i < leonardo($order);$i++){ print "$$tab_ref[$i]\n"; } my $move = 0; #if the tree order is 0 or 1 then its a one element tree, so #its already sorted if($order > 1){ my $tmp; #is left child bigger than father? #if yes swap them if($$tab_ref[$start+leonardo($order)-1] < $$tab_ref[$start+leonardo($order-1)-1]){ $tmp = $$tab_ref[$start+leonardo($order)-1]; $$tab_ref[$start+leonardo($order)-1] = $$tab_ref[$start+leonardo($order-1)-1]; $$tab_ref[$start+leonardo($order-1)-1] = $tmp; $move++; } #is right child bigger than father? if yes swap them elsif ($$tab_ref[$start+leonardo($order)-1]< $$tab_ref[$start+leonardo($order)-2]){ $tmp = $$tab_ref[$start+leonardo($order)-1]; $$tab_ref[$start+leonardo($order)-1] = $$tab_ref[$start+leonardo($order)-2]; $$tab_ref[$start+leonardo($order)-2] = $tmp; $move++; } for(my $i = $start; $i < leonardo($order);$i++){ printf("\n\nheapified:\n"); print "$$tab_ref[$i]\n"; } #now lets do a recursion into the left child heapify($tab_ref,$order-1,$start); #now lets do a recursion into the right child heapify($tab_ref,$order-2,$start+leonardo($order)); if($move > 0){ #lets reheapify myself in case something percolated up print "reheapifying myself:\n"; heapify($tab_ref,$order,$start); } } } sub restring{ my($tab_ref,$trees_ref,$treenum) = @_; my @roots; my ($start,$root) = (0,0); #I create an array containing the indices of all tree roots for(my $i = 0; $i < $treenum;$i++){ ($start,$root) = get_start_root($trees_ref,$i); $roots[$i] = $root; } my $move = 0; #now for each tree root I make sure its bigger than its predecesso +r for(my $i = 0;$i < $#roots+1;$i++){ my $cur = $roots[$i]; #if I'm checking the first root, the predecessor is himself my $prev = $i > 0?$roots[$i-1]:$cur; #if the current root is lower than its predecessor I swap them #then make sure the heap property of both is still ok if($$tab_ref[$cur]<$$tab_ref[$prev]){ my $tmp = $$tab_ref[$cur]; my $debug1 = $$tab_ref[$prev]; print "exchange cur at $cur = $tmp, prev at $prev =$debug1 +\n"; $$tab_ref[$cur] = $$tab_ref[$prev]; $$tab_ref[$prev] = $tmp; $move++; ($start,$root) = get_start_root($trees_ref,$i); heapify($tab_ref,$$trees_ref[$i],$start); ($start,$root) = get_start_root($trees_ref,$i-1); heapify($tab_ref,$$trees_ref[$i-1],$start); } } #if I made any move, the heapify function might have crapped up my #stringing, hence I recurse to make sure everything is ok if($move > 0){ restring($tab_ref,$trees_ref,$treenum); } } sub add_tree{ my($trees_ref,$tree_num_ref,$tab_ref) = @_; my ($start,$root); if($$trees_ref[$$tree_num_ref-1] == $$trees_ref[$$tree_num_ref-2]- +1){ print "contiguous trees: ".$$trees_ref[$$tree_num_ref-2]. $$trees_ref[$$tree_num_ref-1]."\n"; $$trees_ref[$$tree_num_ref-2]++; $$tree_num_ref--; ($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); restring($tab_ref,$trees_ref,$$tree_num_ref); } #if last tree is not of order 1 I create one elsif($$trees_ref[$$tree_num_ref-1] != 1){ $$trees_ref[$$tree_num_ref] = 1; $$tree_num_ref++; ($start,$root) = get_start_root($trees_ref,$$tree_num_ref- +1); heapify($tab_ref,$$trees_ref[$$tree_num_ref-1],$start); restring($tab_ref,$trees_ref,$$tree_num_ref); } #else I create a tree of order 0 else{ $$trees_ref[$$tree_num_ref] = 0; $$tree_num_ref++; ($start,$root) = get_start_root($trees_ref,$$tree_num_ref- +1); heapify($tab_ref,$$trees_ref[$$tree_num_ref-1],$start); restring($tab_ref,$trees_ref,$$tree_num_ref); } } sub smoothsort{ my $tab_ref = shift; my @trees; my $trees_ref = \@trees; my $treenum = 0; #I have more than one value, so I initiate with two trees of l0 an +d l1 if($#$tab_ref > 0){ $$trees_ref[0] = 1; $$trees_ref[1] = 0; $treenum +=2; } #I have only one value else{ $$trees_ref[0] = 0; $treenum++; } my($start,$root); restring($tab_ref,$trees_ref,$treenum); my $cur = 2; print "trees = @trees\n"; while($cur < $#$tab_ref+1){ add_tree($trees_ref,\$treenum,$tab_ref); print "added tree: now \n"; for(my $i = 0; $i < $treenum;$i++){ print $$trees_ref[$i]."\n"; } $cur++; } #now that I'm done tree building and stringing I can start to dequ +eue: #starting from the last tree print "now dequeuing\n"; while($treenum > 0){ print "treenum $treenum\n"; my $cur_tree = $$trees_ref[$treenum-1]; print "doing tree of order $cur_tree\n"; ($start,$root)=get_start_root($trees_ref,$treenum-1); print"removing root ".$$tab_ref[$root]." at $root\n"; if($cur_tree > 1){ #this tree has children, hence it is broken up in two subt +rees #the first is of the same order minus one takes the place +of #its father, the second one of same order minus two is add +ed $$trees_ref[$treenum] = $$trees_ref[$treenum-1]-2; $$trees_ref[$treenum-1] -= 1; $treenum++; print "added tree: now \n"; for(my $i = 0; $i < $treenum;$i++){ print $$trees_ref[$i]."\n"; } ($start,$root) = get_start_root($trees_ref,$treenum-1); restring($tab_ref,$trees_ref,$treenum); heapify($tab_ref,$$trees_ref[$treenum-1],$start); ($start,$root) = get_start_root($trees_ref,$treenum-2); heapify($tab_ref,$$trees_ref[$treenum-2],$start); } else{ $treenum--; } } } sub get_start_root{ my ($trees_ref,$tree_ind) = @_; my ($start,$root) = (0,0); #if it is the first tree, then its start indice is 0 if($tree_ind > 0){ for(my $i = 0; $i < $tree_ind;$i++){ $start += leonardo($$trees_ref[$i]); } } $root = $start + leonardo($$trees_ref[$tree_ind])-1; return ($start,$root); } =head my $n = $ARGV[0]; my @tab; for(my $i = 0; $i < $n;$i++){ $tab[$i] = int(rand(1000)); } =cut my @tab = qw( 446 651 889 706 521 643 326 446 10);# 433 ); print "unsorted tab = @tab\n"; smoothsort(\@tab); print "sorted tab = @tab\n"

if you give tab less than 10 values it ends up sorted, if you uncomment the last value then there is a problem : one of the leonardo trees during dequeuing ends up losing his max heap property.