Merge pull request #9980 from boblied/w265

Week 265 solutions from Bob Lied

3 files changed, 147 insertions, 3 deletions

diff --git a/challenge-265/bob-lied/README b/challenge-265/bob-lied/README
index 3267f8159b..4cf62bac69 100644
--- a/challenge-265/bob-lied/README
+++ b/challenge-265/bob-lied/README
@@ -1,4 +1,4 @@
-Solutions to weekly challenge 264 by Bob Lied
+Solutions to weekly challenge 265 by Bob Lied
 
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-264/
-https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-264/bob-lied
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-265/
+https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-265/bob-lied
diff --git a/challenge-265/bob-lied/perl/ch-1.pl b/challenge-265/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..f81787cbf0
--- /dev/null
+++ b/challenge-265/bob-lied/perl/ch-1.pl
@@ -0,0 +1,58 @@
+#!/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 265 Task 1 33% Appearance
+#=============================================================================
+# You are given an array of integers, @ints.
+# Write a script to find an integer in the given array that appeared 33%
+# or more. If more than one found, return the smallest. If none found then
+# return undef.
+# Example 1 Input: @ints = (1,2,3,3,3,3,4,2)
+#           Output: 3
+#   1 appeared 1 times.  2 appeared 2 times.  3 appeared 4 times.
+#   3 appeared 50% (>33%) in the given array.
+#
+# Example 2 Input: @ints = (1,1)
+#           Output: 1
+#
+# Example 3 Input: @ints = (1,2,3)
+#           Output: 1
+#   1 appeared 1 times.  2 appeared 1 times.  3 appeared 1 times.
+#   Since all three appeared 33.3% (>33%) in the given array.
+#   We pick the smallest of all.
+#=============================================================================
+
+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;
+
+say appear33(@ARGV);
+
+sub appear33(@ints)
+{
+    use List::MoreUtils qw/frequency/;
+    use List::Util qw/min/;
+
+    my %f = frequency(@ints);
+    return min grep { $f{$_} / $#ints > 0.33 } keys %f;
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( appear33(1,2,3,3,3,3,4,2), 3, "Example 1");
+    is( appear33(1,1            ), 1, "Example 2");
+    is( appear33(1,2,3          ), 1, "Example 3");
+
+    done_testing;
+}
diff --git a/challenge-265/bob-lied/perl/ch-2.pl b/challenge-265/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..7e5d4e1740
--- /dev/null
+++ b/challenge-265/bob-lied/perl/ch-2.pl
@@ -0,0 +1,86 @@
+#!/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 265 Task 2 Completing Word
+#=============================================================================
+# You are given a string, $str containing alphnumeric characters, and an
+# array of strings (alphabetic characters only), @str.
+# Write a script to find the shortest completing word.
+# If none found return empty string.
+#
+# A completing word is a word that contains all the letters in the given
+# string, ignoring space and number. If a letter appeared more than once in
+# the given string then it must appear the same number or more in the word.
+# Example 1 Input: $str = 'aBc 11c'
+#                  @str = ('accbbb', 'abc', 'abbc')
+#           Output: 'accbbb'
+#   The given string contains following, ignoring case and number:
+#   a 1 time, b 1 time, c 2 times
+#   The only string in the given array that satisfies the condition is 'accbbb'.
+# Example 2 Input: $str = 'Da2 abc'
+#                  @str = ('abcm', 'baacd', 'abaadc')
+#           Output: 'baacd'
+#   The given string contains following, ignoring case and number:
+#   a 2 times, b 1 time, c 1 time, d 1 time,
+#   Two strings in the array satisfy the condition ('baacd' and 'abaadc')
+#   but 'baacd' is shorter.
+# Example 3 Input: $str = 'JB 007'
+#                  @str = ('jj', 'bb', 'bjb')
+#           Output: 'bjb'
+#=============================================================================
+
+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;
+
+my $str = shift;
+say cw($str, @ARGV);
+
+sub lfreq($str)
+{
+    use List::MoreUtils qw/frequency/;
+    my %f = frequency( split(//, $str) );
+    return \%f;
+}
+
+sub satisfies($need, $have)
+{
+    use List::Util qw/all/;
+    all { ($have->{$_} // 0) >= $need->{$_} } keys %$need;
+}
+
+sub cw($str, @str)
+{
+    # $str = lc($str);
+    # $str =~ s/[^a-z]//g;
+    # my $need = lfreq($str);
+
+    my $need = lfreq((my $s = lc($str)) =~ s/[^a-z]//gr);
+
+    my @candidates = sort { length($a) <=> length($b) }
+                        grep { satisfies($need, lfreq($_)) } @str;
+    return ( @candidates ? $candidates[0] : '' );
+}
+
+sub runTest
+{
+    use Test2::V0;
+
+    is( cw('aBc 11c', qw(accbbb abc abbc)  ), 'accbbb', "Example 1");
+    is( cw('Da2 abc', qw(abcm baacd abaadc)), 'baacd' , "Example 2");
+    is( cw('JB 007' , qw(jj bb bjb)        ), 'bjb'   , "Example 3");
+
+    is( cw('perl'   , qw(python ruby java) ), '',     , "None work");
+
+    done_testing;
+}