laurent_r

These are some answers to the Week 218 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Note: the programs presented here were written several days ago, but I was unable to write this blog post in time due to various reasons, including lack of time and some serious problems with my computer.

Task 1: Maximum Product

You are given a list of 3 or more integers.

Write a script to find the 3 integers whose product is the maximum and return it.

Example 1

Input: @list = (3, 1, 2)
Output: 6

1 x 2 x 3 => 6

Example 2

Input: @list = (4, 1, 3, 2)
Output: 24

2 x 3 x 4 => 24

Example 3

Input: @list = (-1, 0, 1, 3, 1)
Output: 3

1 x 1 x 3 => 3

Example 4

Input: @list = (-8, 2, -9, 0, -4, 3)
Output: 216

-9 × -8 × 3 => 216

Maximum Product in Raku

The program first sorts the input integers in ascending order of their absolute values. Then it looks for products of either only positive values, or products with an even count of negative values. Since the number of edge cases can become somewhat large, I decided to go to brute force once the first simple cases have been tested with no solution.

sub max-prod (@in) {
    my @list = reverse sort { .abs }, @in;
    return [*] @list[0..2] if @list[0..2].all > 0 
        or @list[0..2].one > 0;
    if @list[0..2].all < 0 {
        # find first positive value to replace one neg
        my $first = @list[3..@list.end].first({ $_ > 0});
        return [*] (@list[0..1], $first).flat if $first.defined;
    } 
    # brute force if we get here
    my @comb-prods = gather {
        for @list.combinations: 3 -> @comb {
            take [*] @comb;
        }
    }
    return @comb-prods.max;
}
for (3, 1, 2), (4, 1, 3, 2), (-1, 0, 1, 3, 1), 
    (-8, 2, -9, 0, -4, 3), (-8, 2, 3, 5, 6) -> @test {
    say "@test[]".fmt("%-15s => "), max-prod @test;
}

This program displays the following output:

$ raku ./max-prod.raku
3 1 2           => 6
4 1 3 2         => 24
-1 0 1 3 1      => 3
-8 2 -9 0 -4 3  => 216
-8 2 3 5 6      => 90

Maximum Product in Perl

The program first sorts the input integers in ascending order of their absolute values. Then it looks for products of either only positive values, or products with an even count of negative values. Note that I decided to go for brute force one step earlier than in Raku.

use strict;
use warnings;
use feature 'say';

sub prod {
    my $prod = shift;
    $prod *= $_ for @_;
    return $prod;
}

sub max_prod {
    my @list = sort { abs($b) <=> abs($a) } @_;
    return prod @list[0..2] if 0 < prod @list[0..2];
    # brute force if we get here
    my $max = $_[0];
    for my $i (0..$#list) {
        for my $j ($i+1..$#list) { 
            for my $k ($j+1..$#list) {
                my $prod = $list[$i] * $list[$j] * $list[$k];
                $max = $prod if $prod > $max;
            }
        }
    }
    return $max;
}
for my $test ([3, 1, 2], [4, 1, 3, 2], [-1, 0, 1, 3, 1], 
    [-8, 2, -9, 0, -4, 3], [-8, 2, 3, 5, 6]) {
    printf "%-15s => ", "@$test";
    say max_prod @$test;
}

This program displays the following output:

$ perl ./max-prod.pl
3 1 2           => 6
4 1 3 2         => 24
-1 0 1 3 1      => 3
-8 2 -9 0 -4 3  => 216
-8 2 3 5 6      => 90

Task 2: Matrix Score

You are given a m x n binary matrix i.e. having only 1 and 0.

You are allowed to make as many moves as you want to get the highest score.

A move can be either toggling each value in a row or column.

To get the score, convert the each row binary to dec and return the sum.

Example 1:

Input: @matrix = [ [0,0,1,1],
                   [1,0,1,0],
                   [1,1,0,0], ]
Output: 39

Move #1: convert row #1 => 1100
         [ [1,1,0,0],
           [1,0,1,0],
           [1,1,0,0], ]

Move #2: convert col #3 => 101
         [ [1,1,1,0],
           [1,0,0,0],
           [1,1,1,0], ]

Move #3: convert col #4 => 111
         [ [1,1,1,1],
           [1,0,0,1],
           [1,1,1,1], ]

Score: 0b1111 + 0b1001 + 0b1111 => 15 + 9 + 15 => 39

Example 2:

Input: @matrix = [ [0] ] Output: 1

Matrix Score in Raku

The toggle_col toggles values in a matrix column. The rest of the program is a heuristic approach rather than an algorithm, i.e. it is quite likely to produce the best result or at least something fairly close to it, but there may be some pathological inputs for which the program won’t be able to find the best solution. The main reason for that is that there is no obvious limit to the number of moves. The general idea is to pack as many 1’s as possible in the left rows because they are the most significant digits for the final result.

sub toggle_col (@in, $i) {
    for 0..@in.end -> $j {
        @in[$j][$i] = +not @in[$j][$i];
    }
}
sub improve-score (@in) {
    my $col-max = @in.elems - 1;
    my $row-max = @in[0].elems - 1;
    for @in -> @row {
        if @row[0] == 0 {
            $_ = +not $_ for @row;
        }
    }
    for 0..$row-max -> $index {
        my @col; 
        push @col, @in[$_][$index] for 0..$col-max;
        toggle_col(@in, $index) if @in.elems/2 > [+] @col;
    }
    return @in;
}

my @test = [0,0,1,1], [1,0,1,0], [1,1,0,0];
say "Test: ", @test;
my @new-mat =  improve-score @test;
say "Result: ", @new-mat;
say "Score: ", [+] map {$_.join('').parse-base(2)}, @new-mat;

This program displays the following output:

$ raku ./matrix-score.raku
Test: [[0 0 1 1] [1 0 1 0] [1 1 0 0]]
Result: [[1 1 1 1] [1 0 0 1] [1 1 1 1]]
Score: 39

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on June 4, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.