#!/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"
[download]