PWC 197

PWC 197

I did not attempt the challenges in Julia this time. I have solutions in Perl 5 and Raku.

Challenge 1 (Move Zero)

We are given a list of integers, say (3,0,1,0,5). We are asked to sort the list so that all zeros move to the end, and the remaining items are in their original relative order. In my example, the sorted list would be (3,1,5,0,0).

This is a one-liner in Perl 5 and Raku.

Perl 5:

perl -wl -e 'my @o = sort { ($a == 0) ? 1 : ( ($b == 0) ? -1 : 0 ) } @ARGV; print "@o"' $@

Raku:

raku -e 'say @*ARGS.sort( { ($^a == 0) ?? 1 !! ( ($^b == 0) ?? -1 !! 0 ) } )' $@

The logic is via the block argument to sort. This takes two parameters $a and $b representing two elements in the list being compared. If the comparison returns -1, then $a precedes $b in the sorted list. If the comparison returns 1, then $b precedes $a in the sorted list. If the comparison returns 0, then the order doesn't matter.

The sort pattern here follows this logic:

If both $a and $b are non-zero, they can be in any relative order in the sorted list. Return 0.

If $a is zero, then return 1. In this case, $b should precede $a. (It's fine even if $b is zero too).

If $b is zero and $a is not, then return -1. In this case, $a should precede $b.

This works in recent versions of Perl 5 (I'm not sure how recent), which keep the relative order of $a and $b the same as the original list if 0 is returned. With older versions of Perl 5, the relative order of $a and $b with 0 would be arbitrary, and there's no guarantee that the non-zero items would maintain their original relative order. 

Challenge 2 (Wiggle Sort)

I have not quite solved the problem as specified by our host, and this time I also have not met the test examples. Let me first state the problem I have solved, and then I will state the difference from the specification.

The problem I solved: We are given a list of integers say @list. We are asked to sort them so that $list[0] <= $list[1] >= $list[2] <= $list[3] ... The terms with even-numbered positions in the sorted list are less than or equal to the adjacent terms on both sides with odd-numbered positions (Positions here of course start with 0 as in Perl 5 or Raku).

Our host's specification makes this a strict inequality: $list[0] < $list[1] > $list[2] ... There is no guarantee of a solution in that case (consider for example, a list with all members equal e.g., 1,1,1,1,1,1). Also (like with the weak inequalities), the solution if it exists is not guaranteed to be unique. This makes the test examples less useful, because there are several alternative answers that are as good as the one given.

Coming back to the more general problem that I solved, I first attempted to do it via a block argument to sort as in Challenge 1. I could not achieve this, though I suspect that it should be possible. It is tricky because the comparison of $a and $b depends on their position in the list after it is sorted.

The approach I ended up with was to first sort in descending order, $list[0] >= $list[1] >= $list[2] ... I then swap the elements for each pair of indices (0,1), (2,3), (4,5), ... giving $list[0] <= $list[1] >= $list[2] <= $list[3] ... exactly as we want. Here is my Perl 5 subroutine to do it (with a nested sub-subroutine to do the swapping of elements). The complete Perl 5 script is here.

sub wiggle_sort {
    #-- subsub
    local *wiggle = sub {
        my ($n)=@_;
        ($n+1, $n);
    };

    #-- wiggle_sort root sub
    my @list = @_;
    my @retval;
    
    @list = sort {$b <=> $a} @list;
    
    for (my $i = 0; ($i <= (scalar(@list)-2)); $i += 2) {
        push @retval, @list[&wiggle($i)];    
    }
    (@list % 2) && (push @retval, $list[-1]);
    @retval;
}

Raku is a direct cut-paste-edit translation, except that I moved the nested sub out to a separate subroutine (full Raku code here).

sub wiggle_sort(@list) {
    my @retval;
    
    my @list_ = @list.sort({$^b <=> $^a}).flat;
    
    loop (my $i = 0; ($i <= (@list_.elems)-2); $i += 2) {
        push @retval, (@list_[&wiggle($i)]);    
    }
    (@list_ % 2) && (push @retval, @list_[*-1]);
    @retval.List.flat;
}

#-- subsub
sub wiggle (Int $n) {
    $n+1, $n;
}

Comments

Post a Comment

Popular posts from this blog

PWC 215

PWC 215 I have attempted the Perl Weekly Challenge after a hiatus of several weeks, as I was too busy at work. Still busy, so I have just attempted the current challenge in Perl 5. Like I like to do, I have restricted myself to perl 4 syntax as specified in the first edition of Programming perl. Update and disclaimer : These programs will not work on Perl 4 as I discovered later when I found and installed a Perl 4.019 executable. For one thing, the ability to assign a subroutine to a locally scoped typeglob was not available in Perl 4. Challenge 1 (Odd one out) In this challenge, we are given a list of alphabetic strings, and asked to return the list without the strings in which the characters are not sorted (I assume that this means sorted in lexical ascending order). We are also asked to print the number of strings that were removed (i.e., that were not sorted).  I use a subroutine &odd_one_out(@words) with a nested helper sub-sub-routine to check if a string is sorted. Here i
Read more

PWC 227

PWC 227 Challenge 1 (Friday 13th) This challenge requires us to count the number of times Friday 13th occurs in a particular year. I use Date::Manip. This module probably has easier ways to do this using a Date Range, but my approach is easy enough. My &friday_13th subroutine takes the year as input, throws an exception if it is outside the specified range (1753 to 9999), and then cycles through the 13th of each month, counting the Fridays. use Date::Manip; my $dateobj=Date::Manip::Date->new(); sub friday_13th {     my ($year)=@_;     my $retval=0;     ( ($year > 9999) || ($year < 1753) ) &&         die "Year should be between 1753 and 9999";     map {         ( ($dateobj->new_date("$year-$_-13")->printf('%w') ) == 5 ) &&             $retval++;     }     1 .. 12;          $retval; }   Challenge 2 (Roman Maths) This challenge requires us to implement a calculator that parses infix math operations using roman numerals.  There
Read more

PWC 234

PWC 234 I tried to restrict to Perl 4 syntax for both challenges this week, as documented in Rex Swain's Perl 4 reference or the 1st edition of Programming perl. I do use nested subroutines, which I am not sure would actually work in Perl 4, though they comply with the syntax. My programs are tested on Perl 5.38. (The -l in the shebang line works only in Perl 5. The Perl 4 equivalent was -L012 in Unix, which is no longer available.) As I have mentioned before, my aims in using the old syntax are just mild nostalgia plus to add a bit of additional challenge to the task. I know that this is not the most efficient or idiomatic way to do things today. But I should observe that it is really cool that I am able to write code using 30-year old syntax, and run it unmodified on the latest Perl 5.38. You cannot do this with Python 3 for example. This very deep backward compatibility is one of those unsung underappreciated beauties of Perl 5. In my opinion, it is a very cool thing in
Read more