PWC 218

PWC 218

Challenge 1 (Maximum Product)

We are given a list of integers, which can include negative integers and zero as well as positive integers. We are asked to find the product of any three elements of the list which is the highest of any product so formed. It is stipulated that the list must have at least three elements.

To solve, I sort the list in numeric order. Then the maximum product is given by one of the following:

  1. The product of the lowest two elements and the maximum element. This is if the lowest two elements are both negative (so that their product is positive).
  2. The product of the highest three elements. 

Here is the core subroutine:

use List::Util qw(max);

local *maximum_product = sub {
    
    local *myprod=sub {
        $_[0]*$_[1]*$_[2];
    };

    #-- main part of &maximum_product
    my @list = sort {$a <=> $b} @_;
    
    (scalar(@list) < 2) && (die "Need at least 3 elements in input");

    max(
        &myprod( $list[0], $list[1], $list[-1] ),
        &myprod( $list[-1], $list[-2], $list[-3] )
    );
}; 

Challenge 2 (Matrix Score)

We are given a matrix with ncol columns and nrow rows, with all the elements being either 1 or 0. We are allowed to transform the matrix by flipping every element (from 0 to 1 or 1 to 0) in a single row or in a single column. We evaluate a metric that is the sum of the joined elements of every row expressed as a binary integer. For example, for the matrix  [1 1 1 1; 1 0 0 1; 1 1 1 1] this would be (in Perl 5 notation): 0b1111+0b1001+0b1111, which equals 39 in decimal representation.  We are asked to find the highest possible such score that can emerge at the end of a sequence of allowed moves (flipping rows or columns).

I found an easy O(2N) algorithm here. The logic is as follows:

  1. In the final transformed matrix, every row should start with 1. This is because a row starting with 0 can always be improved on by flipping it. So, we start by flipping every row starting with zero, so that we have a transformed matrix with the first column all ones.
  2. Now we cycle through columns. For each column, we can improve the overall score by flipping the column if the number of zeros in the column pre-flipping is more than half the number of rows nrow.

Kudos to the brilliant person who came up with this. I doubt I would have done so on my own.

I use PDL to implement this. Here is the core subroutine:

use PDL;
use PDL::NiceSlice;
use PDL::AutoLoader;

sub matrix_score {

    local *flip_col = sub {
        my ($col)=@_;
        $matrix($col) .= !$matrix($col); #--[See point 1. below]
    };
    
    local *flip_row = sub {
        my ($row)=@_;
        $matrix(,$row) .= !$matrix(,$row); #--[See point 1. below]
    };
    
    local *binary_row = sub {
        my ($row)=@_;
        oct '0b' . (join( '', $matrix(,$row)->list)); #--[See point 2. below]
    };

    #-- main portion of sub
    local ($matrix)=@_; #--pdl
    #-- I leave out input validation chores
    
    my ($ncol, $nrow)=($matrix->dims);
    
    for my $ctr (0 .. $nrow-1) {
    #-- check if row starts with 0, if so, flip
        ($matrix(0,$ctr)==0) && (&flip_row($ctr));
    }
    
    for my $ctr (0 .. $ncol-1) {
    #-- check if number of 1's in column < 0.5 * nrow
    #-- if so, flip column
    ( ($matrix($ctr)->sum) < ($nrow/2) ) && ( &flip_col($ctr) );
    }
    
    #-- add up binary representations of each row    
    my $retval=0b0;
    for my $ctr (0 .. $nrow-1) {
        $retval += &binary_row($ctr);
    }
    sprintf("%d",$retval);
}
 

Some notes:

  1. I could have in theory used a matrix of bits which would have improved efficiency (but PDL does not appear to support this). In that case, the bitwise not ~ would have been the operator used to flip an element rather than the boolean not ! which I use here. In plain Perl 5, the boolean not ! has the unwanted effect of representing False with an empty string rather than a zero. But luckily for our purpose here, PDL overrides this behavior and uses a zero.
  2. Unfortunately, Perl 5 does not magically treat '0b1111' as a number when used in an arithmetic operation. We have to explicitly cast it as a number. Not very intuitively, this is done with the oct('0b1111') operator, which converts it to an octal number (internally, that's just the same as any other base number).
     
I rely on slow interpreted Perl 5 loops to cycle through rows or columns, which is not the best way to do things with PDL. It should be possible to improve efficiency by vectorizing these.  Fellow-contributor Jo S has brilliant vectorization using the bitwise xor operator (^).  Rather than looping through rows to flip those starting with 1, they just xor (^) the matrix with the negation (!) of its first column. The second loop through columns is a bit more complicated, involving first transposing the matrix, and then using the sumover method to identify columns that have too many zeroes. Transforming the matrix is accomplished using xor (^) again. Very cool and masterly stuff that demonstrates just how powerful and flexible a tool PDL can be.

Comments

Post a Comment

Popular posts from this blog

PWC 258

PWC 258 Last week (#257) I finished challenge 2 and my blog post for challenge 257 late last week, so had only submitted challenge 1. Here is my blog post for PWC 257 , including the full code for my challenge 2 solution. This week, I have done both challenges in perl 4.019 on DOSBOX. Both scripts also work fine on the latest Perl 5.38. I also did the challenges in Raku, where they are one-liners.  Challenge 1 (Count Even Digits Number) We are given a list of integers, and asked to count the number of elements whose base-10 representation has an even number of digits. In Raku , this is a one-liner. Here it is: raku -e 'say +@*ARGS.grep({$_.chars %% 2})' $@ It could be a one-liner in Perl 4 too, but since I run it on DOSBOX, my script would not be a bash shell script. Here is the short subroutine that does the job.  sub count_even_digits {  scalar( grep( ((length($_) % 2) == 0), @_) ); } The full code is here . Challenge 2 (Sum of values) We are given an integer k  and a list in
Read more

PWC 249

PWC 249 Challenge 1 (Equal pairs) We are given a list of integers with an even number of elements. We are asked to check if the list can be completely divided into sub-lists of size 2 with each sub-list containing the same integer repeated, like say (2,2). If so, we are asked to return the list of such sub-lists. This is straightforward in Perl 5. I use modern conveniences this time, though it could be done using only primitive Perl 4 syntax. Here is my subroutine. It returns a list of array references. local *equal_pairs = sub {     #-- return () if input is of odd length     ((scalar(@_) % 2) > 0) && (return ());          #-- count number of occurrences of each element using a hash     local %_ = ();     map {$_{$_}++} @_;          #-- if any element occurs an odd number of times, return ()     (grep {($_{$_} % 2) > 0} keys %_) && (return ());          #-- loop thru %_ keys, returning pairs of such keys     map {         my $k=$_;         my $num_pairs=( ($_{$k}
Read more

PWC 253

PWC 253 I do both challenges this week using old software on DOSBOX: perl 4.019, and for comparison, also python 1.4 beta. My solutions also work on the current versions of Perl 5 (5.38) and Python 2 (2.7.18) respectively. Challenge 1 (Split Strings) Links to code: perl4.019 python1.4b We are given a list of strings, and a single character say sep . We are asked to return the list, with the strings split into component substrings using sep as a separator. We should not include any empty strings in the output. In perl 4, I first stick a backslash in front of the separator character, so that it is escaped if entered in a regex. This is because the perl split function takes a regex as its first argument indicating the separator. If we have a character like '$' or ',', we want to escape it so that it is read literally when parsing the regex. Here is the key subroutine:   sub split_strings {  local ($separator, @words)=@_;  local (@retval)=(); #array to be returned  #  #--
Read more