Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

comment on

( #3333=superdoc: 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"

In reply to Smoothsort by QuillMeantTen

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others chanting in the Monastery: (8)
    As of 2020-11-26 09:55 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      No recent polls found

      Notices?