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