#!/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 heap
    {
    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 return;
    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);;
      }
    }
  }