RabbitFarm

2025-03-27

Equally Sorted

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1: Equal Strings

You are given three strings. You are allowed to remove the rightmost character of a string to make all equals. Write a script to return the number of operations to make it equal otherwise -1.

The fact that we’re give exactly three strings makes things slightly easier. The approach we’ll take is to pop off the last letter of each and compare the remainders. If they are equal then we are done. Otherwise we’ll continue popping off letter until we’re done.

A special case to consider is when the strings are of unequal length. In that case we make sure to only pop off letters from equal length strings, although the untouched strings will still be used when checking to see if we are done.

Everything can be easily contained in one subroutine. I know that the do blocks with postfix if are not common, but to me they are the most aesthetic way to conditionally perform two short statements.

⟨loop, pop, and compare 1 ⟩≡


sub loop_pop_compare{
my($s, $t, $u) = @_;
my @s = split //, $s;
my @t = split //, $t;
my @u = split //, $u;
my $counter = 0;
{
my $max_size = (sort {$b <=> $a} (0 + @s, 0 + @t, 0 + @u))[0];
unless(join(q//, @s) eq join(q//, @t) &&
join(q//, @t) eq join(q//, @u)){
do{$counter++; pop @s} if @s == $max_size;
do{$counter++; pop @t} if @t == $max_size;
do{$counter++; pop @u} if @u == $max_size;
}
else{
return $counter;
}
redo unless @s == 0 || @t == 0 || @u == 0;
}
return -1;
}
◇

Fragment referenced in 2.

Putting it all together...

"ch-1.pl" 2≡


⟨preamble 3 ⟩
⟨loop, pop, and compare 1 ⟩
⟨main 4 ⟩
◇

⟨preamble 3 ⟩≡


use v5.40;
◇

Fragment referenced in 2, 9.

The rest of the code just runs some simple tests.

⟨main 4 ⟩≡


MAIN:{
say loop_pop_compare q/abc/, q/abb/, q/ab/;
say loop_pop_compare q/ayz/, q/cyz/, q/xyz/;
say loop_pop_compare q/yza/, q/yzb/, q/yzc/;
}
◇

Fragment referenced in 2.

Sample Run
$ perl perl/ch-1.pl 
2 
-1 
3

Part 2: Sort Column

You are given a list of strings of same length. Write a script to make each column sorted lexicographically by deleting any non sorted columns. Return the total columns deleted.

Unlike the first part, the strings here are guaranteed to be all of the same length and we do not know how many we will need to consider.

⟨get a column 5 ⟩≡


my $column = [map {my @w = split //, $_; $w[$i]} @{$s}];
◇

Fragment referenced in 8.

Defines: $column 6.

Uses: $i 8, $s 8.

⟨determine if the column is sorted 6 ⟩≡


my @sorted = sort {$a cmp $b} @{$column};
my @check = grep {$sorted[$_] eq $column->[$_]} 0 .. @{$column} - 1;
my $sorted = 0 + @check == 0 + @sorted;
◇

Fragment referenced in 8.

Defines: $sorted 8.

Uses: $column 5.

⟨get every other column 7 ⟩≡


my $remaining = [grep {$string->[$_] if $_ != $i} 0 .. @{$string} - 1];
◇

Fragment never referenced.

Defines: $remaining Never used.

Uses: $i 8.

We’ll put everything together in a single subroutine.

⟨sort columns 8 ⟩≡


sub sort_columns{
my $s = [@_];
my $i = 0;
my $removals = 0;
do{
my $i = $_;
⟨get a column 5 ⟩
⟨determine if the column is sorted 6 ⟩
$removals++ unless $sorted;
} for 0 .. length($s->[0]) - 1;
return $removals;
}
◇

Fragment referenced in 9.

Defines: $i 5, 7, $s 5.

Uses: $sorted 6.

The rest of the code drives some tests.

"ch-2.pl" 9≡


⟨preamble 3 ⟩
⟨sort columns 8 ⟩
⟨main 10 ⟩
◇

⟨main 10 ⟩≡


MAIN:{
say sort_columns qw/swpc tyad azbe/;
say sort_columns qw/cba daf ghi/;
say sort_columns qw/a b c/;
}
◇

Fragment referenced in 9.

Sample Run
$ perl perl/ch-2.pl 
2 
1 
0

References

The Weekly Challenge 314
Generated Code

posted at: 18:14 by: Adam Russell | path: /perl | permanent link to this entry