Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Smoothsort

by QuillMeantTen (Friar)
on Sep 20, 2015 at 11:42 UTC ( #1142552=CUFP: print w/replies, xml ) Need Help??

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"

Replies are listed 'Best First'.
Re: Smoothsort
by ambrus (Abbot) on Sep 21, 2015 at 08:28 UTC

    Please link to the previous post leading here: Smoothsort.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://1142552]
Approved by Athanasius
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (6)
As of 2020-10-22 12:21 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My favourite web site is:












    Results (225 votes). Check out past polls.

    Notices?