RabbitFarm

2025-03-23

Reverse Broken Keys for Letters

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

Part 1: Broken Keys

You have a broken keyboard which sometimes type a character more than once. You are given a string and actual typed string. Write a script to find out if the actual typed string is meant for the given string.

What we’re faced with here is a problem of removing consecutive duplicated letters. The trick is that some letters may be correctly duplicated in succession! For example “coffeescript”has two f’s and two e’s which are not in error. We’re given the correct version so wee need to track the current correct letter and find deviations.

Another special case to consider is when the deviations occur at the end of the string and we get all of the same repeated letters as in the “rrakuuuu”example. To address this we check if the repeated letters remaining match the last known good letter.

Our solution is to loop over the letters in the candidate string guided by the original word. We do this all in one subroutine, the code is not so unwieldy to need to be broken into smaller pieces.

⟨loop and compare 1 ⟩≡


sub loop_compare{
my($n, $s) = @_;
my @n = split //, $n;
my @s = split //, $s;
my $current_n = q//;
my $current_s = q//;
{
my $previous_n = $current_n;
$current_n = shift @n;
$current_s = shift @s;
if($current_s ne $current_n && $current_s eq $previous_n){
unshift @n, $current_n;
{
$current_s = shift @s;
redo if $current_s eq $previous_n && @s > 0;
unshift @s, $current_s;
}
}
return 0 if $current_s ne $current_n && $current_s ne $previous_n;
redo if @n > 0 && @s > 0;
}
return 1 if (@n == 0 && @s ==0) || (@s == grep {$_ eq $current_s} @s);
return 0;
}
◇

Fragment referenced in 2.

We really just need one subroutine to co-ordinate the inputs and run the main loop that’s required.

Putting it all together...

"ch-1.pl" 2≡


⟨preamble 3 ⟩
⟨loop 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_compare q/perl/, q/perrrl/;
say loop_compare q/raku/, q/rrakuuuu/;
say loop_compare q/python/, q/perl/;
say loop_compare q/coffeescript/, q/cofffeescccript/;
}
◇

Fragment referenced in 2.

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

Part 2: Reverse Letters

You are given a string. Write a script to reverse only the alphabetic characters in the string.

First we separate the alphabetic characters from the string, then we reverse them, then we finish by recombining the reversed alphabetic characters with the non-alphabetic characters.

⟨remove alphabetic characters 5 ⟩≡


my $a = [grep {$_ =~ m/[[:alpha:]]/} @{$s}];
◇

Fragment referenced in 8.

Defines: $a 6, 7.

Uses: $s 8.

⟨reverse the alphabetic characters 6 ⟩≡


$a = [reverse @{$a}];
◇

Fragment referenced in 8.

Uses: $a 5.

⟨combine the sorted alphabetic characters with the non-alphabetic characters 7 ⟩≡


{
my $c = shift @{$s};
push @{$reverse_letters}, $c if $c !~ m/[[:alpha:]]/;
push @{$reverse_letters}, shift @{$a} if $c =~ m/[[:alpha:]]/;
redo if @{$s} > 0;
}
◇

Fragment referenced in 8.

Uses: $a 5, $reverse_letters 8, $s 8.

We’ll put everything together in a single subroutine.

⟨reverse_letters: co-ordinates all the swaps and checks 8 ⟩≡


sub reverse_letters{
my($s) = (@_);
$s = [split //, $s];
my $reverse_letters = [];
⟨remove alphabetic characters 5 ⟩
⟨reverse the alphabetic characters 6 ⟩
⟨combine the sorted alphabetic characters with the non-alphabetic characters 7 ⟩
return join q//, @{$reverse_letters};
}
◇

Fragment referenced in 9.

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

The rest of the code drives some tests.

"ch-2.pl" 9≡


⟨preamble 3 ⟩
⟨reverse_letters: co-ordinates all the swaps and checks 8 ⟩
⟨main 10 ⟩
◇

⟨main 10 ⟩≡


MAIN:{
say reverse_letters q/p-er?l/;
say reverse_letters q/wee-k!L-y/;
say reverse_letters q/_c-!h_all-en!g_e/;
}
◇

Fragment referenced in 9.

Sample Run
$ perl perl/ch-2.pl 
l-re?p 
yLk-e!e-w 
_e-!g_nel-la!h_c

References

The Weekly Challenge 313
Generated Code

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