PWC 257

PWC 257

I finished late this week, so I just submitted Challenge 1. But I finished Challenge 2 later without submitting it to github and will just post the entire code on this blog. I did both challenges in perl 4.019 on DOSBOX. For challenge 1, I also did it in python 1.4 beta on DOSBOX. Challenge 2 I only attempted in Perl. My solutions work in current versions of perl 5 (5.38) and python 2, though with warnings of the deprecated perl 4 package separator when I run challenge 2 in perl 5. 

Challenge 1 (Smaller than current)

We are given a list of integers ints say. We are asked to return a list of numbers giving at each index i the count of how many elements in ints are less than the element at ints[i].

Here is the perl 4 subroutine [link to github]:

sub smaller_than_current {
 local(@ints)=@_;
 local(@ranks)=(sort {$ints[$a]<=>$ints[$b];} 0..$#ints);
 local($i,@retval);
 
 $retval[$ranks[0]]=0;
 foreach $i (1 .. $#ranks){
  if ($ints[$ranks[$i]]==$ints[$ranks[$i-1]]) {
   $retval[$ranks[$i]]=$retval[$ranks[$i-1]];
  }
  else {
   $retval[$ranks[$i]]=$i;
  }
 }
 @retval;
}

We use sort with a custom function to rank the indices of ints in ascending order of the element at that index. This rank is the same as the number of int elements less than the element at that index, except that we need to make a minor adjustment for ties

Here is the almost direct translation to python [link to github]:

def smaller_than_current( intuple ):
 ranks=[]
 for i in range(len(intuple)):
  ranks.append((intuple[i],i))
 ranks.sort()
 ranks=map(lambda x:x[1], ranks)
 retval=[None]*len(intuple)
 retval[ranks[0]]=0
 for i in range(1,len(ranks)):
  if intuple[ranks[i]]==intuple[ranks[i-1]]:
   retval[ranks[i]]=retval[ranks[i-1]]
  else:
   retval[ranks[i]]=i
 return retval

Challenge 2 (Reduced Row Echelon)

We are given a matrix and asked to ascertain if it is in "reduced row echelon" form. If it is:

  1. The first non-zero element (if any) of each row is 1. Let us call it the leading 1,
  2. The column in which the leading 1 occurs has all other elements equal to zero.
  3. The leading 1 in any row is to the right of the leading 1 in the previous row.
  4. All-zero rows (if any) are all at the bottom of the matrix.

I  use a home-made perl 4 matrix package called mtrx to conjure up some convenience functions: to read in a matrix (as hash) from a string, to return the row or the column of a matrix, and to give the number of rows. I then create the key subroutine is_rre to check for reduced row echelon format. It loops through rows and columns applying the criteria.

Here is the entire listing, since it is not on github.

#CH-2.PL
#perl 4.019 on DOSBOX

sub reduced_row_echelon {
 local(%mtrx)=&mtrx'new(@_);
 &mtrx'is_rre(%mtrx);
}

print &reduced_row_echelon("[1,1,0;0,1,0;0,0,0]"),"\n"; #0
print &reduced_row_echelon("[0,1,-2,0,1;0,0,0,1,3;0,0,0,0,0;0,0,0,0,0]"),"\n"; #1
print &reduced_row_echelon("[1,0,0,4; 0,1,0,7; 0,0,1,-1]"),"\n"; #1
print &reduced_row_echelon("[0,1,-2,0,1; 0,0,0,0,0; 0,0,0,1,3; 0,0,0,0,0]"),"\n"; #0
print &reduced_row_echelon("[0,1,0; 1,0,0; 0,0,0]"),"\n"; #0
print &reduced_row_echelon("[4,0,0,0; 0,1,0,7; 0,0,1,-1]"),"\n"; #0

package mtrx;

sub new {
 #read matrix (assoc array) from string
 #of form "[#,#..;#,#]" (matlab style)
 local($new)=@_;
 $new =~ /^\[(.+)\]$/;
 local(@new)=split(/;/,$1);
 local($r,$c); #index thru rows and columns respectively
 local(@row); #temp variable to hold each row
 local(%new); #return value
 foreach $r (0 .. $#new) {
  @row=split(/,/,$new[$r]);
  foreach $c (0 .. $#row) {
    $new{join(",",($c,$r))}=$row[$c];
  }
 }
 %new;
}

sub col {
 #return column indexed c as array
 local( $c, %mtrx )=@_;
 local( @c ) = grep( /^$c,/, keys %mtrx );
 @c = sort {(split(/,/,$a))[1] <=> (split(/,/,$b))[1];} @c;
 @mtrx{@c};
}

sub row {
 #return row indexed r as array
 local( $r, %mtrx )=@_;
 local( @r ) = grep( /,$r$/, keys %mtrx);
 @r = sort {(split(/,/,$a))[0] <=> (split(/,/,$b))[0];} @r;
 @mtrx{@r};
}

sub nrow {
 #return number of rows in column c
 local( $c, %mtrx)=@_;
 local(@col)=&col($c, %mtrx);
 scalar(@col);
}

sub is_rre {
 #check if reduced row echelon
 local(%mtrx)=@_;
 local(@leading_1, $r, $c, @row, @col);
 ROW: foreach $r (0 .. &nrow(0,%mtrx)-1) {
  @row=&row($r,%mtrx);
  $leading_1[$r] = (scalar(@row)+1);
  COL: foreach $c (0 .. $#row) {
   next COL if ($row[$c]==0);
   next ROW if ($leading_1[$r] < (scalar(@row)+1) );
   (return 0) if ($row[$c] != 1);
   $leading_1[$r]=$c;
   (return 0) if ( ($r > 0) && ($leading_1[$r-1] >= $c) );
   @col=&col($c,%mtrx);
   ( scalar(grep($_==0,@col)) < (scalar(@col)-1) ) && (return 0);
  }
 }
 return 1;
}

My mtrx package allows the matrix to be irregular in shape (rows and columns could have varying lengths). Strictly speaking, I should have an additional check in is_rre to make sure that the input matrix is regular in shape. I haven't bothered with this chore.

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