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

Spoiler Alert: This weekly challenge deadline is due in a couple of days from now (on January 1, 2023 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Move Zero

You are given a list of integers, @list.

Write a script to move all zero, if exists, to the end while maintaining the relative order of non-zero elements.

Example 1

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

Example 2

Input: @list = (1, 6, 4)
Output: (1, 6, 4)

Example 3

Input: @list = (0, 1, 0, 2, 0
Output: (1, 2, 0, 0, 0)

Move Zero in Raku

We simply use two greps to pick up non-zero items on the one hand and zero items on the other hand and rearrange them in the desired order by concatenating them.

sub move-zero (@in) {
    return (@in.grep({$_ != 0}), @in.grep({$_ == 0})).flat;
}
for <1 0 3 0 0 5>, <1 6 4>, <0 1 0 2 0> -> @test {
    say (~@test).fmt("%-15s"), " => ", move-zero @test;
}

This program displays the following output:

$ raku ./move-zero.raku
1 0 3 0 0 5     => (1 3 5 0 0 0)
1 6 4           => (1 6 4)
0 1 0 2 0       => (1 2 0 0 0)

Move Zero in Perl

Same method as in Raku: we simply use two greps to pick up non-zero items on the one hand and zero items on the other hand and rearrange them in the desired order.

use strict;
use warnings;
use feature qw/say/;

sub move_zero {
    return ((grep $_ != 0, @_), grep $_ == 0, @_);
}
for my $test ([<1 0 3 0 0 5>], [<1 6 4>], [<0 1 0 2 0>]){
    say "@$test => \t", join " ", move_zero  @$test;
}

This program displays the following output:

$ perl ./move-zero.pl
1 0 3 0 0 5 =>  1 3 5 0 0 0
1 6 4 =>        1 6 4
0 1 0 2 0 =>    1 2 0 0 0

Task 2: Wiggle Sort

You are given a list of integers, @list.

Write a script to perform Wiggle Sort on the given list.

Wiggle sort would be such as list[0] < list[1] > list[2] < list[3]….

Example 1

Input: @list = (1,5,1,1,6,4)
Output: (1,6,1,5,1,4)

Example 2

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

Basically, we need items with even indices to be smaller than the next item and items with odd indices to be larger than the next item.

Note that, for a given input list, there can be several output lists in wiggle order. We will only display the first one found.

Also note that it might be better to specify wiggle sort as follows:

Wiggle sort would be such as list[0] <= list[1] >= list[2] <= list[3]…

as it would make it possible to define output for lists having many times the same item.

We could sort the input list, partition it into two list, one with the larger items and one with the smaller items, and store the larger items in the odd positions and the smaller items in the even positions.

But it can be made simpler: we only need to go through the list one item at a time (e.g. from left to right) and swap current item with the next one when they don’t match the requirement.

Wiggle Sort in Raku

This program implements the observations made at the end of the previous section:

sub wiggle_sort (@in is copy) {
    for 0..^@in.end -> $i {
        if $i %% 2 {
            @in[$i, $i+1] = @in[$i+1, $i] 
                if @in[$i] > @in[$i+1];
        } else {
            @in[$i, $i+1] = @in[$i+1, $i] 
                if @in[$i] < @in[$i+1];
        }
    }
    return @in;
}
for <1 5 1 1 6 4>, <1 3 2 2 3 1>, 
    <8 12 11 13 9>, <1 2 3 4 5 6 7 8 9> -> @test {
    say (~@test).fmt("%-20s => "), wiggle_sort @test;
}

This program displays the following output:

$ raku ./wiggle_sort.raku
1 5 1 1 6 4          => [1 5 1 6 1 4]
1 3 2 2 3 1          => [1 3 2 3 1 2]
8 12 11 13 9         => [8 12 11 13 9]
1 2 3 4 5 6 7 8 9    => [1 3 2 5 4 7 6 9 8]

Wiggle Sort in Perl

This program implements the same method:

use strict;
use warnings;
use feature qw/say/;

sub wiggle_sort {
    my @in = @_;
    for my $i (0..$#in - 1) {
        if ($i % 2) {
            @in[$i, $i+1] = @in[$i+1, $i] 
                if $in[$i] < $in[$i+1];
        } else {
            @in[$i, $i+1] = @in[$i+1, $i] 
                if $in[$i] > $in[$i+1];
        }
    }
    return @in;
}
for my $test ([<1 5 1 1 6 4>], [<1 3 2 2 3 1>], 
    [<8 12 11 13 9>], [<1 2 3 4 5 6 7>]) {
    say "@$test \t=> ", join " ", wiggle_sort @$test;
}

This program displays the following output:

$ perl ./wiggle_sort.pl
1 5 1 1 6 4     => 1 5 1 6 1 4
1 3 2 2 3 1     => 1 3 2 3 1 2
8 12 11 13 9    => 8 12 11 13 9
1 2 3 4 5 6 7   => 1 3 2 5 4 7 6

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 January 8, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on December 25, 2022 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Pattern 132

You are given a list of integers, @list.

Write a script to find out subsequence that respect Pattern 132. Return empty array if none found.

Pattern 132 in a sequence (a[i], a[j], a[k]) such that i < j < k and a[i] < a[k] < a[j].

Example 1

Input:  @list = (3, 1, 4, 2)
Output: (1, 4, 2) respect the Pattern 132.

Example 2

Input: @list = (1, 2, 3, 4)
Output: () since no susbsequence can be found.

Example 3

Input: @list = (1, 3, 2, 4, 6, 5)
Output: (1, 3, 2) if more than one subsequence found then return the first.

Example 4

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

Pattern 132 in Raku

The find_132 subroutine is a recursive subroutine which does different things, depending on the number of items in the partial result array passed to it.

sub find_132 (@input, @part-result) {
    # say @input, " - ", @part-result;
    given @part-result.elems {
        when 3 { return @part-result }
        when 2 {
            for 0..@input.end -> $i {
                my $ret = find_132 @input[$i^..@input.end],
                    (@part-result, @input[$i]).flat
                    if @input[$i] > @part-result[0]
                    && @input[$i] < @part-result[1];
                return $ret if $ret;
            }
        }
        when 1 {
            for 0..@input.end -> $i {
                my $ret =find_132 @input[$i^..@input.end],
                    (@part-result, @input[$i]).flat
                    if @input[$i] > @part-result[0];
                return $ret if $ret;
            }
        }
        when 0 {
            for 0..@input.end -> $i {
                my $ret = find_132(@input[$i^..@input.end],
                    (@input[$i],));
                return $ret if $ret;
            }
        }
    }
}
for <3 1 4 2>, <1 2 3 4>, <1 3 2 4 6 5>, <1 3 4 2> -> @test {
    say @test, "\t=> ", (find_132 @test, ()) // "()";
}

This program displays the following output:

$ raku  ./pattern-132.raku
(3 1 4 2)       => (1 4 2)
(1 2 3 4)       => ()
(1 3 2 4 6 5)   => (1 3 2)
(1 3 4 2)       => (1 3 2)

I’m afraid I got carried away by my love for recursive solutions. Using a recursive subroutine might in our case be overkill, or over-engineering, especially in view of the fact that we always need three steps, so that these steps can easily be hard-coded in an iterative loop. In the real life, I would probably rewrite it with an iterative approach. In the case of this challenge, I’ll simply try that option in the Perl implementation.

Pattern 132 in Perl

Using a recursive subroutine is useful when there is an unpredictable, or rather variable, number of nested loops, depending on the input data. Here, we know that we essentially need three loops, one for each integer in the output. So, rather than porting to Perl the recursive approach used in Raku, we’ll try an iterative approach with three nested hard-coded loops, which should presumably be simpler.

use strict;
use warnings;
use feature qw/say/;

sub find_132 {
    my @in = @_;
    for my $i (0..$#in) {
        my @out = ($in[$i]);
        for my $j ($i+1..$#in) {
            next unless $in[$j] > $out[0];
            my @out2 = (@out, $in[$j]);
            for my $k ($j+1..$#in) {
                if ($in[$k] > $out2[0] 
                    and $in[$k] < $out2[1]) {
                    return @out2, $in[$k];
                }
            }
        }
    }
    return "()"; # no solution if we've got here
}
for my $test ( [<3 1 4 2>], [<1 2 3 4>], 
               [<1 3 2 4 6 5>], [<1 3 4 2>] ) {
    say "@$test \t=> ", join " ", find_132 @$test;
}

The find_123 subroutine is only is only 17 code lines (versus 30 lines for the recursive version used in the Raku implementation), so this is definitely significantly shorter, and also, I believe, simpler.

This program displays the following output:

$ perl  ./pattern-132.pl
3 1 4 2         => 1 4 2
1 2 3 4         => ()
1 3 2 4 6 5     => 1 3 2
1 3 4 2         => 1 3 2

Task 2: Range List

You are given a sorted unique integer array, @array.

Write a script to find all possible Number Range i.e [x, y] represent range all integers from x and y (both inclusive).

Each subsequence of two or more contiguous integers

Example 1

Input: @array = (1,3,4,5,7)
Output: [3,5]

Example 2

Input: @array = (1,2,3,6,7,9)
Output: [1,3], [6,7]

Example 3

Input: @array = (0,1,2,4,5,6,8,9)
Output: [0,2], [4,6], [8,9]

Range List in Raku

We loop over the input list and keep track of successive ranges.

sub find-ranges (@in) {
    my ($start, $curr);
    my @result;
    $start = $curr = @in[0];
    for 1..@in.end -> $i {
        next if @in[$i] == $start;
        if @in[$i] == $curr + 1 {
            $curr = @in[$i];
        } else {
            push @result, "[$start $curr]" 
                if $curr - $start > 0;
            $start = @in[$i];
            $curr = $start;
        }
    }
    push @result, "[$start $curr]" if $curr > $start;
    return @result.elems > 0 ?? @result !! "[]";
}
for <1 3 4 5 7>, <1 2 3 6 7 9>, <0 1 2 4 5 6 8 9>,
    <1 3 4 6 7 11 12 13>, <1 3 4 5 7 9>, <1 3 5> -> @test {
    printf "%-20s => %s\n", ~@test, ~find-ranges @test;
}

This program displays the following output:

$ raku ./find-ranges.raku
1 3 4 5 7            => [3 5]
1 2 3 6 7 9          => [1 3] [6 7]
0 1 2 4 5 6 8 9      => [0 2] [4 6] [8 9]
1 3 4 6 7 11 12 13   => [3 4] [6 7] [11 13]
1 3 4 5 7 9          => [3 5]
1 3 5                => []

Range List in Perl

This is a port to Perl of the Raku program just above:

use strict;
use warnings;
use feature qw/say/;

sub find_ranges {
    my @in = @_;
    my ($start, $curr);
    my @result;
    $start = $curr = $in[0];
    for my $i (1..$#in) {
        next if $in[$i] == $start;
        if ($in[$i] == $curr + 1) {
            $curr = $in[$i];
        } else {
            push @result, "[$start $curr] " 
                if $curr > $start;
            $start = $in[$i];
            $curr = $start;
        }
    }
    push @result, "[$start $curr]" if $curr > $start;
    return @result > 0 ? @result : "[]";
}
for my $test ([<1 3 4 5 7>], [<1 2 3 6 7 9>], 
    [<0 1 2 4 5 6 8 9>], [<1 3 4 6 7 11 12 13>], 
    [<1 3 4 5 7 9>], [<1 3 5>]) {
    say sprintf("%-25s", "@$test => "), find_ranges @$test;
}

This program displays the following output:

$ perl ./find-ranges.pl
1 3 4 5 7 =>             [3 5]
1 2 3 6 7 9 =>           [1 3] [6 7]
0 1 2 4 5 6 8 9 =>       [0 2] [4 6] [8 9]
1 3 4 6 7 11 12 13 =>    [3 4] [6 7] [11 13]
1 3 4 5 7 9 =>           [3 5]
1 3 5 =>                 []

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 January 1, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on December 18, 2022 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Special Integers

You are given a positive integer, $n > 0.

Write a script to print the count of all special integers between 1 and $n.

An integer is special when all of its digits are unique.

Example 1:

Input: $n = 15
Output: 14 as except 11 all other integers between 1 and 15 are spcial.

Example 2:

Input: $n = 35
Output: 32 as except 11, 22, 33 all others are special.

Special Integers in Raku

The is-special subroutine stores the digits into a set ($h), which has the property of removing duplicates. At the end, if the set has the same number of elements as the number of characters in the input number, then there is no duplicate: the number is special and the subroutine returns a True value. Otherwise, it returns a False value.

sub is-special ($n) {
    # return True if $n.chars == 1;
    my $h = set $n.comb;
    return $h.elems == $n.chars;
}

for 15, |(32..45), 1232, 1233, 1234 -> $m {
    my $count = $m <= 9 ?? $m !!  9;
    for 10..$m -> $i {
        $count++ if is-special $i;
    }
    say "$m \t -> $count";
}

This program displays the following output:

$ raku ./special-numbers.raku
15       -> 14
32       -> 30
33       -> 30
34       -> 31
35       -> 32
36       -> 33
37       -> 34
38       -> 35
39       -> 36
40       -> 37
41       -> 38
42       -> 39
43       -> 40
44       -> 40
45       -> 41
1232     -> 802
1233     -> 802
1234     -> 803

Note that, as we go from 32 to 33, the number of special integers remains the same, as 33 is obviously not a special number. The same behavior is observed when we reach 44 or 1233.

Special Integers in Perl

The is_special subroutine stores the digits into a hash ($h), which has the property of removing duplicates. At the end, if the hash has the same number of elements as the number of characters in the input number, then there as no duplicate: the number is special and the subroutine returns a True value. Otherwise, it returns a False value.

use strict;
use warnings;
use feature qw/say/;

sub is_special {
    my $n = shift;
    # return True if length $n == 1;
    my %h = map { $_ => 1} split //, $n;
    return scalar %h == length $n;
}

for my $m (15, 32..45, 1232, 1233, 1234) {
    my $count = $m <= 9 ? $m : 9;
    for my $i (10..$m) {
        $count++ if is_special $i;
    }
    say "$m \t -> $count";
}

This script displays the following output:

$ perl ./special-numbers.pl
15       -> 14
32       -> 30
33       -> 30
34       -> 31
35       -> 32
36       -> 33
37       -> 34
38       -> 35
39       -> 36
40       -> 37
41       -> 38
42       -> 39
43       -> 40
44       -> 40
45       -> 41
1232     -> 802
1233     -> 802
1234     -> 803

Task 2: Most Frequent Even Number

You are given a list of numbers, @list.

Write a script to find most frequent even numbers in the list. In case you get more than one even numbers then return the smallest even integer. For all other case, return -1.

Example 1

Input: @list = (1,1,2,6,2)
Output: 2 as there are only 2 even numbers 2 and 6 and of those 2 appears the most.

Example 2

Input: @list = (1,3,5,7)
Output: -1 since no even numbers found in the list

Example 3

Input: @list = (6,4,4,6,1)
Output: 4 since there are only two even numbers 4 and 6. They both appears the equal number of times, so pick the smallest.

Most Frequent Even Number in Raku

The find-frequent-int subroutine does almost all of the work (the rest is just setting the test cases and displaying the result). This subroutine first discard the odd integers and fills an histogram hash with counters for each even integer. If the histogram is empty (i.e. there is no even integer in the input list), then the subroutine returns -1. Otherwise, the sort does essentially all the work: it sorts the histogram hash in descending order of values and then (in case of a draw) in ascending order of keys. It then simply returns the first hash key, which is bound to be the highest frequency and the smallest integer when there is a frequency draw.

sub find-frequent-int (@in) {
    my %histo = map { $_ => ++%histo{$_} }, 
                grep { $_ %% 2 }, @in;
    return -1 if %histo.elems < 1;
    return ( sort { %histo{$^b} <=> %histo{$^a} 
                  || $^a <=> $^b }, 
          %histo.keys ).first;
}
for < 1 1 2 6 2>, <1 3 5 7>, <6 4 4 6 1>, < 8 4 8 6 4 6>,
    < 8 4 8 6 4 6 8>, < 6 4 8 6 4 6 8> -> @test {
    say @test, " => ", find-frequent-int @test;
}

This script displays the following output:

$ raku ./frequent-even.raku
(1 1 2 6 2) => 2
(1 3 5 7) => -1
(6 4 4 6 1) => 4
(8 4 8 6 4 6) => 4
(8 4 8 6 4 6 8) => 8
(6 4 8 6 4 6 8) => 6

Most Frequent Even Number in Perl

This is essentially a port to Perl of the above Raku program. The find_frequent_int subroutine does almost all of the work (the rest is just setting the test cases and displaying the result). This subroutine first discard the odd integers and fills an histogram hash with counters for each even integer. If the histogram is empty (i.e. there is no even integer in the input list), then the subroutine returns -1. Otherwise, the sort does essentially all the work: it sorts the histogram hash in descending order of values and then (in case of a draw) in ascending order of keys. It then simply returns the first hash key, which is bound to be the highest frequency and the smallest integer when there is a frequency draw.

use strict;
use warnings;
use feature qw/say/;

sub find_frequent_int {
    my %histo;
    %histo = map { $_ => ++$histo{$_} } 
             grep { $_ % 2 == 0 } @_;
    return -1 if scalar %histo < 1;
    return ( sort { $histo{$b} <=> $histo{$a} 
                    || $a <=> $b } keys %histo)[0];
}
for my $test ([<1 1 2 6 2>], [<1 3 5 7>], [<6 4 4 6 1>], 
    [<8 4 8 6 4 6>], [<8 4 8 6 4 6 8>], [<6 4 8 6 4 6 8>]) {
    say "@$test => ", find_frequent_int @$test;
}

This script displays the following output:

$ perl frequent-even.pl
1 1 2 6 2 => 2
1 3 5 7 => -1
6 4 4 6 1 => 4
8 4 8 6 4 6 => 4
8 4 8 6 4 6 8 => 8
6 4 8 6 4 6 8 => 6

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 December 25, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on December 11, 2022 at 23:59). This blog post offers some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Digital Clock

You are given time in the format hh:mm with one missing digit.

Write a script to find the highest digit between 0-9 that makes it valid time.

Example 1

Input: $time = '?5:00'
Output: 1

Since 05:00 and 15:00 are valid time and no other digits can fit in the missing place.

Example 2

Input: $time = '?3:00'
Output: 2

Example 3

Input: $time = '1?:00'
Output: 9

Example 4

Input: $time = '2?:00'
Output: 3

Example 5

Input: $time = '12:?5'
Output: 5

Example 6

Input: $time =  '12:5?'
Output: 9

The task is quite easy, but a little painful because of the number of cases to be tested.

Digital Clock in Raku

The highest-digit subroutine splits the input qstring into the hour and minute component and figures out in which component the missing digit (the question mark) is.

If the missing digit is in the hour component, and if the first digit is missing, then the subroutine returns 1 if the second digit if more than 3 and 2 otherwise. If the second digit is missing, then it returns 3 if the first digit is 2, and 9 otherwise.

If the missing digit is in the minute component, then the suboutine returns 5 if it is the first digit that is missing, and 9 if it is the second digit.

sub highest-digit ($in) {
    my ($h, $m) = $in.split(/\:/);
    # say $h, " ", $m;
    if $h ~~ /\?/ {
        my ($h1, $h2) = $h.comb('');
        if $h1 eq '?' {
            return $h2 > 3 ?? 1 !! 2;
        } elsif $h2 eq '?' {
            return $h1 == 2 ?? 3 !! 9;
        }
    } elsif $m ~~ /\?/ {
        my ($m1, $m2) = $m.comb('');
        return 5 if $m1 eq '?'; 
        return 9 if $m2 eq '?'; 
    }        
}

for <?5:00 ?3:00 1?:00 2?:00 12:?5 12:5? 14:?9> -> $t {
    say "$t => ", highest-digit($t);
}

This program displays the following output:

$ raku ./highest-digit.raku
?5:00 => 1
?3:00 => 2
1?:00 => 9
2?:00 => 3
12:?5 => 5
12:5? => 9
14:?9 => 5

Digital Clock in Perl

This is a port to Perl of the Raku program above. Please refer to the Raku section for explanations on the way the program works.

use strict;
use warnings;
use feature qw/say/;

sub highest_digit  {
    my ($h, $m) = split /\:/, $_[0];
    # say $h, " ", $m;
    if ($h =~ /\?/) {
        my ($h1, $h2) = split //, $h;
        if ($h1 eq '?') {
            return $h2 > 3 ? 1 : 2;
        } elsif ($h2 eq '?') {
            return $h1 == 2 ? 3 : 9;
        }
    } elsif ($m =~ /\?/) {
        my ($m1, $m2) = split //, $m;
        return 5 if $m1 eq '?'; 
        return 9 if $m2 eq '?'; 
    }        
}

for my $t (qw<?5:00 ?3:00 1?:00 2?:00 12:?5 12:5? 14:?9>) {
    say "$t => ", highest_digit($t);
}

This program displays the following output:

$ perl ./highest-digit.pl
?5:00 => 1
?3:00 => 2
1?:00 => 9
2?:00 => 3
12:?5 => 5
12:5? => 9
14:?9 => 5

Task 2: Frequency Equalizer

You are given a string made of alphabetic characters only, a-z.

Write a script to determine whether removing only one character can make the frequency of the remaining characters the same.

Example 1:

Input: $s = 'abbc'
Output: 1 since removing one alphabet 'b' will give us 'abc' where each alphabet frequency is the same.

Example 2:

Input: $s = 'xyzyyxz'
Output: 1 since removing 'y' will give us 'xzyyxz'.

Example 3:

Input: $s = 'xzxz'
Output: 0 since removing any one alphabet would not give us string with same frequency alphabet.

Basically, to answer the question, we need to find out whether all the characters have the same frequency, except for one which occurs once more than the others.

Frequency Equalizer in Raku

We first build the %histo histogram of the letters of the input string. Then we store the sorted values (ascending order) in the @frequencies array and check whether all the values except the last (the largest) are equal and the last value is one more than the others.

sub remove-one ($st) {
    my %histo;
    %histo{$_}++ for $st.comb;
    my @frequencies = %histo.values.sort;
    my $largest = @frequencies.pop;
    return 1 if $largest - 1 == @frequencies.all;
    return 0;
}
for <abbc xyzyyxz xzxz> -> $test {
    say "$test.fmt("%-10s") => ", remove-one($test);
}

This program displays the following output:

$ raku ./freq-analyzer.raku
abbc       => 1
xyzyyxz    => 1
xzxz       => 0

Frequency Equalizer in Perl

We first build the %histo histogram of the letters of the input string. Then we store the sorted values (descending order) in the @frequencies array and check whether all the values except the first (the largest) are equal and the first value is one more than the others. Note that we cannot use an all junction in Perl, so we simply loop over the values (except the first) to check that they are all equal

use strict;
use warnings;
use feature qw/say/;

sub remove_one {
    my %histo;
    $histo{$_}++ for split //, shift;
    my @frequencies = sort { $b <=> $a } values %histo;
    my $largest = shift @frequencies;
    for my $count (@frequencies) {
        return 0 if $largest - 1 != $count;
    }
    return 1;
}
for my $test (<abbc xyzyyxz xzxz>) {
    printf "%-10s => %d\n", $test, remove_one($test);
}

This program displays the following output:

$ perl ./freq-analyzer.pl
abbc       => 1
xyzyyxz    => 1
xzxz       => 0

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 December 18, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.