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.

Replies are listed 'Best First'.
Re: Smoothsort
by Athanasius (Bishop) on Sep 20, 2015 at 07:53 UTC

    Hello QuillMeantTen, and welcome to the Monastery!

    Since this is a learning exercise, I want to comment on your use of C-style for loops. For example, from sub heapify:

    for(my $i = $start; $i < leonardo($order);$i++){ print "$$tab_ref[$i]\n"; }

    As a general rule, whenever you have a C-style for loop in which the reinitialisation expression increments a variable by one, you should re-cast it as a Perl-style foreach loop instead:

    for my $i ($start .. leonardo($order) - 1) { print "$$tab_ref[$i]\n"; }

    Or, even better, put it on a single line by making the foreach a statement modifier:

    print "$$tab_ref[$_]\n" for $start .. leonardo($order) - 1;

    — which has the added advantage of simplifying the code by removing a variable declaration.

    Not only is a Perl foreach loop intrinsically faster than its C-style equivalent; in this case you get a significant extra benefit in efficiency, because the subroutine call to leonardo($order) is made only once. Here’s a longer example to emphasise the point:

    Of course, this works only because the value returned by leonardo($order) doesn’t change (because $order isn’t changed in the body of the loop).

    Another point to note: recursive functions like sub leonardo can often be significantly streamlined by memoization. This is explained in Chapter 3 of Higher-Order Perl by Mark Jason Dominus, which is available for free from http://hop.perl.plover.com/. See also the CPAN module Memoize (also by MJD).

    Update: Fixed off-by-one error in foreach loops, thanks to AnomalousMonk (twice!).

    Hope that helps,

    Athanasius <°(((><contra mundum Iustus alius egestas vitae, eros Piratica,

      Hi Athanasius,

      your point about the range-computing subroutine being called only once when using a Perl-style foreach loop (as compared to the "equivalent" C-style loop) is very interesting.

      I sometimes wondered, in similar cases, whether I should pre-compute the range limits in order to sort of cache them before entering the for loop, but never actually cared to check, now I know that, in such cases, Perl is actually doing the value caching for you. Good to know. Thank you, Athanasius.

Re: Smoothsort
by choroba (Archbishop) on Sep 20, 2015 at 01:04 UTC
    Translated from C (translated from Delphi) by Keith Schwarz and slightly Perlified:

    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');

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

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

      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
    OMG, more that 200 lines of code for the implementation of a sorting algorithm in Perl! That's really inefficient in terms the work invested in coding (developer's hours are a costly resource) and of the risk of bugs, among other things.

    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; }
    Just 17 lines of code, without any attempt to be particularly concise or clever.

    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.

      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";'
    Result:
    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
    Since the standard Perl 'sort' is very powerful and very fast, is there a reason to *improve* it?

    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);
    poj

      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.
Re: Smoothsort
by Tux (Abbot) 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; } }

    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; }

    or using a ternary

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

    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

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

      ha
      sub leonardo { return 1 if 0==$n or 1==$n; return leonardo ($n - 2) + leonardo ($n - 1) + 1; }
      sub leonardo { my $n = shift; $n <= 1 || leonardo ($n - 2) + leonardo ($n - 1) + 1 +; }

      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);; } } }