After a first try that contained some (at least for me) hard to track bugs in the function used to preserve the max heap property of trees and then some much needed refactoring and variable renaming to make the code less cryptic (both thanks to the hints given to me by Athanasius, praised may be his name) I can now give here a working perl implementation of smoothsort.
If anyone can give me hints to make it even more understandable and readable I will update it

Update :@Athanasius: got rid of line 110 and its error leftover from my print debug statements

@ww: Got rid of 2 to make it proper for CUFP, since it seems that saying that improvements suggestions are welcome make this post unfit for CUFP

Link to SoPW post

#!/usr/bin/perl use strict; use warnings; use Memoize; memoize('leonardo'); 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) = @_; 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-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"