Perl Weekly Challenge 296.

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 296.

Task 1: String Compression

Submitted by: Mohammad Sajid Anwar
You are given a string of alphabetic characters, $chars.

Write a script to compress the string with run-length encoding, as shown in
the examples.

A compressed unit can be either a single character or a count followed by
a character.

BONUS: Write a decompression function.

Example 1
Input: $chars = "abbc"
Output: "a2bc"
Example 2
Input: $chars = "aaabccc"
Output: "3ab3c"
Example 3
Input: $chars = "abcc"
Output: "ab2c"

I can use a regular expression to capture each character and its repetitions and replacing them by their length. I use the /e modifier which allows arbitrary Perl expressions in the replacement part of a substitution. This yields a one-liner.

Examples:

perl -E '
for(@ARGV){$x=$_; $x=~s/(.)(\1+)/$1.(1+length $2)/ge; say "$_ -> $x"}
' abbc aaabccc abcc

Results:

abbc -> ab2c
aaabccc -> a3bc3
abcc -> abc2

Note there is a mistake in the problem statement.

I can use a similar one-liner to invert the transformation, using the string repetition operator x.

Examples:

perl -E '
for(@ARGV){$x=$_; $x=~s/(.)(\d+)/"$1" x $2/ge; say "$_ -> $x"}
' ab2c a3bc3 abc2

Results:

ab2c -> abbc
a3bc3 -> aaabccc
abc2 -> abcc

The full code is the following:

 1  # Perl weekly challenge 296
 2  # Task 1:  String Compression
 3  #
 4  # See https://wlmb.github.io/2024/11/18/PWC296/#task-1-string-compression
 5  use v5.36;
 6  die <<~"FIN" unless @ARGV and (my $name=lc shift)=~/compress|decompress/;
 7      Usage: $0 C S1 S2...
 8      to compress or decompress the strings S1 S2
 9      using run length encoding according to the command C, compress or decompress.
10      FIN
11  my %commands=(
12      compress=>sub($x){
13          $x=~/\d/&& warn "Digit found $x"; $x=~s/(.)(\1+)/$1.(1+length $2)/ge;return $x;},
14      decompress=>sub($x){$x=~s/(.)(\d+)/"$1" x $2/ge; return $x}
15      );
16  my $command=$commands{$name};
17  for(@ARGV){
18      say "$_ -> ", $command->($_);
19  }

The strings are taken from @ARGV, to which I add a command, either compress or decompress, as a first argument.

Examples:

./ch-1.pl compress abbc aaabccc abcc
./ch-1.pl decompress ab2c a3bc3 abc2

Results:

abbc -> ab2c
aaabccc -> a3bc3
abcc -> abc2
ab2c -> abbc
a3bc3 -> aaabccc
abc2 -> abcc

Task 2: Matchstick Square

Submitted by: Mohammad Sajid Anwar
You are given an array of integers, @ints.

Write a script to find if it is possible to make one square using the
sticks as in the given array @ints where $ints[ì] is the length of ith stick.

Example 1
Input: @ints = (1, 2, 2, 2, 1)
Output: true

Top: $ints[1] = 2
Bottom: $ints[2] = 2
Left: $ints[3] = 2
Right: $ints[0] and $ints[4] = 2
Example 2
Input: @ints = (2, 2, 2, 4)
Output: false
Example 3
Input: @ints = (2, 2, 2, 2, 4)
Output: false
Example 4
Input: @ints = (3, 4, 1, 4, 3, 1)
Output: true

I first find out the sum of all elements and divide it by four to obtain the length of each side. Then I use a recursive function that tries to add to the first element each of the others, one at a time. If the first element grows larger than the side, the attempt fails. If it equals the side, it is removed and the routine recurses over the remaining elements. If it is smaller, it is kept and the routine recurses. If the list becomes empty, the attempt is successful and the program terminates. The result fits a 3-liner.

Example 1:

perl -MList::Util=sum0 -E '
sub f(@l){$s=sum0(@l);return 0 if $s%4;$s/=4;return g(@l)}sub g(@l){return 1 unless @l;
my $f=shift(@l);return 0 if $f>$s;return g(@l)if $f==$s;for(1..@l-1){return 1 if g($f+$l[$_],
@l[1..$_-1,$_+1..@l-1])}return 0;}say "@ARGV -> ", f(@ARGV)?"True":"False"
' 1 2 2 2 1

Results:

1 2 2 2 1 -> True

Example 2:

perl -MList::Util=sum0 -E '
sub f(@l){$s=sum0(@l);return 0 if $s%4;$s/=4;return g(@l)}sub g(@l){return 1 unless @l;
my $f=shift(@l);return 0 if $f>$s;return g(@l)if $f==$s;for(1..@l-1){return 1 if g($f+$l[$_],
@l[1..$_-1,$_+1..@l-1])}return 0;}say "@ARGV -> ", f(@ARGV)?"True":"False"
' 2 2 2 4

Results:

2 2 2 4 -> False

Example 3:

perl -MList::Util=sum0 -E '
sub f(@l){$s=sum0(@l);return 0 if $s%4;$s/=4;return g(@l)}sub g(@l){return 1 unless @l;
my $f=shift(@l);return 0 if $f>$s;return g(@l)if $f==$s;for(1..@l-1){return 1 if g($f+$l[$_],
@l[1..$_-1,$_+1..@l-1])}return 0;}say "@ARGV -> ", f(@ARGV)?"True":"False"
' 2 2 2 2 4

Results:

2 2 2 2 4 -> False

Example 4:

perl -MList::Util=sum0 -E '
sub f(@l){$s=sum0(@l);return 0 if $s%4;$s/=4;return g(@l)}sub g(@l){return 1 unless @l;
my $f=shift(@l);return 0 if $f>$s;return g(@l)if $f==$s;for(1..@l-1){return 1 if g($f+$l[$_],
@l[1..$_-1,$_+1..@l-1])}return 0;}say "@ARGV -> ", f(@ARGV)?"True":"False"
' 3 4 1 4 3 1

Results:

3 4 1 4 3 1 -> True

The full code is:

 1  # Perl weekly challenge 296
 2  # Task 2:  Matchstick Square
 3  #
 4  # See https://wlmb.github.io/2024/11/18/PWC296/#task-2-matchstick-square
 5  use v5.36;
 6  use List::Util qw(sum0);
 7  die <<~"FIN" unless @ARGV;
 8      Usage: $0 L1 L2...
 9      to build a square by joining sticks of lengths L1, L2...
10      FIN
11  my $side;
12  sub test(@list){
13      my $sum = sum0(@list);
14      return 0 if $sum %4; # fails if sum is not multiple of 4.
15      $side = $sum/4;
16      return test_aux(@list)
17  }
18  sub test_aux(@list){
19      return 1 unless @list; # success if list is empty
20      my $first = shift(@list);
21      return 0 if $first > $side;
22      return test_aux(@list) if $first == $side; # Matched one side, test the rest
23      for(1..@list-1){ # join two sticks and test
24          return 1 if test_aux($first + $list[$_], @list[1..$_-1,$_+1..@l-1])
25      }
26      return 0; # fail if joining no stick to the first succeded
27  }
28  say "@ARGV -> ", test(@ARGV)?"True":"False";

Examples:

./ch-2.pl 1 2 2 2 1
./ch-2.pl 2 2 2 4
./ch-2.pl 2 2 2 2 4
./ch-2.pl 3 4 1 4 3 1

Results:

1 2 2 2 1 -> True
2 2 2 4 -> False
2 2 2 2 4 -> False
3 4 1 4 3 1 -> True

/;

Written on November 18, 2024