Week 270 solutions

3 files changed, 192 insertions, 3 deletions

diff --git a/challenge-270/bob-lied/README b/challenge-270/bob-lied/README
index 546c6eeb9a..3bc8c7afd0 100644
--- a/challenge-270/bob-lied/README
+++ b/challenge-270/bob-lied/README
@@ -1,4 +1,4 @@
-Solutions to weekly challenge 269 by Bob Lied
+Solutions to weekly challenge 270 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-269/
-https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-269/bob-lied
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-270/
+https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-270/bob-lied
diff --git a/challenge-270/bob-lied/perl/ch-1.pl b/challenge-270/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..5cbd51f959
--- /dev/null
+++ b/challenge-270/bob-lied/perl/ch-1.pl
@@ -0,0 +1,95 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# Copyright (c) 2024, Bob Lied
+#=============================================================================
+#  
+# ch-1.pl Perl Weekly Challenge 270 Task 1 Special Positions
+#=============================================================================
+# You are given a m x n binary matrix.
+# Write a script to return the number of special positions in the given
+# binary matrix.  A position (i, j) is called special if
+# $matrix[i][j] == 1 and all other elements in the row i and column j are 0.
+# Example 1 Input: $matrix = [ [1, 0, 0],
+#                              [0, 0, 1],
+#                              [1, 0, 0], ]
+#           Output: 1
+#   There is only one special position (1, 2) as $matrix[1][2] == 1
+#   and all other elements in row 1 and column 2 are 0.
+# Example 2 Input: $matrix = [ [1, 0, 0],
+#                              [0, 1, 0],
+#                              [0, 0, 1], ]
+#           Output: 3
+#=============================================================================
+
+use v5.38;
+
+use builtin qw/true false/; no warnings "experimental::builtin";
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+sub columnOf($matrix, $col)
+{
+    map { $_->[$col] } $matrix->@*;
+}
+
+sub specialPos($matrix)
+{
+    use List::Util qw/sum/;
+    use List::MoreUtils qw/indexes/;
+
+    my $special = 0;
+
+    for ( 0 .. $matrix->$#* )
+    {
+        my @ones = indexes { $_ == 1 } $matrix->[$_]->@*;
+        $special++ unless ( @ones != 1 ) || (sum columnOf($matrix, $ones[0]) ) != 1;
+    }
+
+    return $special;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    my $matrix = [ [1,0,0], [0,0,1], [1,0,0] ];
+    is( specialPos($matrix), 1, "Example 1");
+
+    $matrix = [ [1,0,0], [0,1,0], [0,0,1] ];
+    is( specialPos($matrix), 3, "Example 2");
+
+    $matrix = [ [0,0,0,0], [0,0,0,0] ];
+    is( specialPos($matrix), 0, "All zero");
+
+    $matrix = [ [1,1,1,1], [1,1,1,1], [1,1,1,1] ];
+    is( specialPos($matrix), 0, "All one");
+
+    $matrix = [ [0,0], [1,0], [0,0], [1,1] ];
+    is( specialPos($matrix), 0, "row > col");
+
+    $matrix = [ [1] ];
+    is( specialPos($matrix), 1, "degenerate 1x1 with 1");
+
+    $matrix = [ [0] ];
+    is( specialPos($matrix), 0, "degenerate 1x1 with 0");
+
+    $matrix = [ [0,0,0] ];
+    is( specialPos($matrix), 0, "one row, 0");
+
+    $matrix = [ [0,1,0] ];
+    is( specialPos($matrix), 1, "one row, 1");
+
+    $matrix = [ [1,1,0] ];
+    is( specialPos($matrix), 0, "one row, 2");
+
+    $matrix = [ [1], [0], [0], [0] ];
+    is( specialPos($matrix), 1, "one col, 1");
+
+    done_testing;
+}
diff --git a/challenge-270/bob-lied/perl/ch-2.pl b/challenge-270/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..cdc7442665
--- /dev/null
+++ b/challenge-270/bob-lied/perl/ch-2.pl
@@ -0,0 +1,94 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# Copyright (c) 2024, Bob Lied
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge 270 Task 2 Equalize Array
+#=============================================================================
+# You are give an array of integers, @ints and two integers, $x and $y.
+# Write a script to execute one of the two options:
+# Level 1: Pick an index i of the given array and do $ints[i] += 1
+# Level 2: Pick two different indices i,j and do $ints[i] +=1 and $ints[j] += 1.
+# You are allowed to perform as many levels as you want to make every elements
+# in the given array equal. There is cost attach for each level, for Level 1,
+# the cost is $x and $y for Level 2.
+# In the end return the minimum cost to get the work done.
+#
+# Example 1 Input: @ints = (4, 1), $x = 3 and $y = 2
+#           Output: 9
+#   Level 1: i=1, so $ints[1] += 1.  @ints = (4, 2)
+#   Level 1: i=1, so $ints[1] += 1.  @ints = (4, 3)
+#   Level 1: i=1, so $ints[1] += 1.  @ints = (4, 4)
+#   We performed operation Level 1 three times,
+#   so the total cost would be 3 x $x => 3 x 3 => 9
+#
+# Example 2 Input: @ints = (2, 3, 3, 3, 5), $x = 2 and $y = 1
+#           Output: 6
+#   Level 2: i=0, j=1, $ints[0]++ and $ints[1]++, @ints = (3, 4, 3, 3, 5)
+#   Level 2: i=0, j=2, $ints[0]++ and $ints[2]++, @ints = (4, 4, 4, 3, 5)
+#   Level 2: i=0, j=3, $ints[0]++ and $ints[3]++, @ints = (5, 4, 4, 4, 5)
+#   Level 2: i=1, j=2, $ints[1]++ and $ints[2]++, @ints = (5, 5, 5, 4, 5)
+#   Level 1: i=3, so $ints[3] += 1                @ints = (5, 5, 5, 5, 5)
+#   We perforned operation Level 1 one time and Level 2 four times.
+#   So the total cost would be (1 x $x) + (4 x $y) => (1 x 2) + (4 x 1) => 6
+#=============================================================================
+
+use v5.38;
+
+use Getopt::Long;
+my $X; my $Y;
+my $DoTest  = 0;
+
+GetOptions("test" => \$DoTest, "x:i" => \$X, "y:i" => \$Y);
+exit(!runTest()) if $DoTest;
+
+say equalizeArray(\@ARGV, $X, $Y);
+
+sub equalizeArray($ints, $lvl1cost, $lvl2cost)
+{
+    use List::Util qw/max sum/;
+
+    my $target = max $ints->@*;
+    my $addsNeeded = sum map { $target - $_ } $ints->@*;
+
+    if ( $ints->$#* < 1 )
+    {
+        # Nothing to add to, no moves possible
+        return 0;
+    }
+    elsif ( $ints->$#* == 1 )
+    {
+        # Only Level 1 moves are possible.
+        return $addsNeeded * $lvl1cost;
+    }
+
+    if ( $lvl2cost <= 2 * $lvl1cost )
+    {
+        # Increment 2 at a time as long as we can
+        my $cost  = $lvl2cost * int( $addsNeeded / 2 );
+        $cost += $lvl1cost if $addsNeeded % 2;
+        return $cost;
+    }
+    else
+    {
+        # Cheaper just to Level 1 moves
+        return $addsNeeded * $lvl1cost;
+    }
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( equalizeArray([4,1],       3, 2),  9, "Example 1");
+    is( equalizeArray([2,3,3,3,5], 2, 1),  6, "Example 2");
+    is( equalizeArray([2,4,3,3,5], 2, 1),  4, "Example 2");
+
+    is( equalizeArray([5],         3, 2),  0, "No moves");
+    is( equalizeArray([ ],         3, 2),  0, "Empty list");
+
+    is( equalizeArray([4,1,1],     3, 9), 18, "Expensive level 2");
+    is( equalizeArray([4,1,1],     3, 6), 18, "lvl2 = 2 * lvl1");
+
+    done_testing;
+}