From b83ae6bf5ef619abe85510b5810b8b7e84a5224f Mon Sep 17 00:00:00 2001 From: Bob Lied Date: Tue, 5 Dec 2023 16:30:41 -0600 Subject: Make random number picks unique --- challenge-246/bob-lied/perl/ch-1.pl | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/challenge-246/bob-lied/perl/ch-1.pl b/challenge-246/bob-lied/perl/ch-1.pl index 394f4db426..07c2d59d52 100644 --- a/challenge-246/bob-lied/perl/ch-1.pl +++ b/challenge-246/bob-lied/perl/ch-1.pl @@ -10,4 +10,12 @@ #============================================================================= use feature qw/say/; -say for sort { $a <=> $b} map { int(rand(49)) + 1 } 1..6; + +# Choose six numbers without repeats +my %seen; +while ( scalar(%seen) < 6 ) +{ + $seen{ int(rand(49)) + 1 } = 1; +} + +say for sort { $a <=> $b } keys %seen; -- cgit From 8c83d2379bec6a8df0291d5d2831ebbfe3051e41 Mon Sep 17 00:00:00 2001 From: Bob Lied Date: Tue, 5 Dec 2023 16:45:33 -0600 Subject: Correct size of hash --- challenge-246/bob-lied/perl/ch-1.pl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/challenge-246/bob-lied/perl/ch-1.pl b/challenge-246/bob-lied/perl/ch-1.pl index 07c2d59d52..56b1ae4e26 100644 --- a/challenge-246/bob-lied/perl/ch-1.pl +++ b/challenge-246/bob-lied/perl/ch-1.pl @@ -13,7 +13,7 @@ use feature qw/say/; # Choose six numbers without repeats my %seen; -while ( scalar(%seen) < 6 ) +while ( scalar(keys %seen) < 6 ) { $seen{ int(rand(49)) + 1 } = 1; } -- cgit From f52eeb84259418b208d965ac7f97819de86bd8de Mon Sep 17 00:00:00 2001 From: Bob Lied Date: Mon, 11 Dec 2023 08:50:57 -0600 Subject: PWC 24 task 1 done --- challenge-247/bob-lied/README | 6 +- challenge-247/bob-lied/perl/ch-1.pl | 111 ++++++++++++++++++++++++++++++++++++ 2 files changed, 114 insertions(+), 3 deletions(-) create mode 100644 challenge-247/bob-lied/perl/ch-1.pl diff --git a/challenge-247/bob-lied/README b/challenge-247/bob-lied/README index 2c14618b4f..ddf6e99243 100644 --- a/challenge-247/bob-lied/README +++ b/challenge-247/bob-lied/README @@ -1,4 +1,4 @@ -Solutions to weekly challenge 246 by Bob Lied +Solutions to weekly challenge 247 by Bob Lied -https://perlweeklychallenge.org/blog/perl-weekly-challenge-246/ -https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-246/bob-lied +https://perlweeklychallenge.org/blog/perl-weekly-challenge-247/ +https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-247/bob-lied diff --git a/challenge-247/bob-lied/perl/ch-1.pl b/challenge-247/bob-lied/perl/ch-1.pl new file mode 100644 index 0000000000..e201bff1d6 --- /dev/null +++ b/challenge-247/bob-lied/perl/ch-1.pl @@ -0,0 +1,111 @@ +#!/usr/bin/env perl +# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu: +#============================================================================= +# Copyright (c) 2023, Bob Lied +#============================================================================= +# part1.pl Perl Weekly Challenge 247 Task 1 Secret Santa +#============================================================================= +# Secret Santa is a Christmas tradition in which members of a group are +# randomly assigned a person to whom they give a gift. +# You are given a list of names. Write a script that tries to team persons +# from different families. The givers are randomly chosen but don't share +# family names with the receivers. +# Example 1 Input: @names = ( +# 'Mr. Wall', 'Mrs. Wall', 'Mr. Anwar', 'Mrs. Anwar', +# 'Mr. Conway', 'Mr. Cross',); +# Output: Mr. Conway -> Mr. Wall +# Mr. Anwar -> Mrs. Wall +# Mrs. Wall -> Mr. Anwar +# Mr. Cross -> Mrs. Anwar +# Mr. Wall -> Mr. Conway +# Mrs. Anwar -> Mr. Cross +# Example 2 One gift is given to a family member. +# Input: @names = ('Mr. Wall', 'Mrs. Wall', 'Mr. Anwar',); +# Output: Mr. Anwar -> Mr. Wall +# Mr. Wall -> Mrs. Wall +# Mrs. Wall -> Mr. Anwar +#============================================================================= + +use v5.38; +use builtin qw/true false/; no warnings "experimental::builtin"; + +use List::Util qw/all sample/; + +use Getopt::Long; +my $Verbose = 0; +my $DoTest = 0; + +GetOptions("test" => \$DoTest, "verbose" => \$Verbose); +exit(!runTest()) if $DoTest; + +my $picks = secretSanta(@ARGV); +say "$_ -> $picks->{$_}" for + sort { surname($a) cmp surname($b) || $a cmp $b } keys %$picks; + +sub secretSanta(@names) +{ + return {} if ( @names < 2 ); + my %picks; +PICKEM: + my %available = map { $_ => true } @names; + for my $name (@names) + { + my @choices = grep { surname($_) ne surname($name) } keys %available; + if ( @choices == 0 ) + { + # Must pick within family, but not self + @choices = grep { $_ ne $name } keys %available; + + # If we got down to one person picking themselves, try again + if ( @choices == 0 ) + { + warn "Self-pick detected, retry"; + %picks = (); + goto PICKEM; + } + } + + my $recipient = sample 1, @choices; + delete $available{$recipient}; + + $picks{$name} = $recipient; + } + return \%picks +} + +sub surname($name) { (split(" ", $name))[-1]; } + +sub runTest +{ + use Test2::V0; + + my @names; my $picks; + @names = ( 'Mr. Wall', 'Mrs. Wall', 'Mr. Anwar', 'Mrs. Anwar', + 'Mr. Conway', 'Mr. Cross',); + my $expect = { + 'Mr. Anwar' => 'Mrs. Wall' , + 'Mr. Conway' => 'Mr. Wall' , + 'Mr. Cross' => 'Mrs. Anwar', + 'Mr. Wall' => 'Mr. Conway', + 'Mrs. Anwar' => 'Mr. Cross' , + 'Mrs. Wall' => 'Mr. Anwar' , + }; + $picks = secretSanta(@names); + + is( scalar(keys %$picks), scalar(@names), "Enough picks"); + ok( (all { exists $picks->{$_} } @names), "All givers have a recipient"); + is( [sort @names], [sort values %$picks], "Every one gets a gift"); + ok( (all { $_ ne $picks->{$_} } @names), "No one picks themselves"); + ok( (all { surname($_) ne surname($picks->{$_}) } @names ), "All picks outside family"); + + @names = ( 'Mr. Wall', 'Mrs. Wall', 'Mr. Anwar' ); + $picks = secretSanta(@names); + + is( scalar(keys %$picks), scalar(@names), "Enough picks"); + ok( (all { exists $picks->{$_} } @names), "All givers have a recipient"); + is( [sort @names], [sort values %$picks], "Every one gets a gift"); + ok( (all { $_ ne $picks->{$_} } @names), "No one picks themselves"); + is( surname($picks->{'Mr. Anwar'}), 'Wall', "Anwar picks a Wall"); + + done_testing; +} -- cgit From cf780136eaea2075524c500d5989bcf5403d8c9b Mon Sep 17 00:00:00 2001 From: Bob Lied Date: Mon, 11 Dec 2023 08:58:41 -0600 Subject: PWC 247 Task 2 complete --- challenge-247/bob-lied/perl/ch-2.pl | 44 +++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 challenge-247/bob-lied/perl/ch-2.pl diff --git a/challenge-247/bob-lied/perl/ch-2.pl b/challenge-247/bob-lied/perl/ch-2.pl new file mode 100644 index 0000000000..07735608c3 --- /dev/null +++ b/challenge-247/bob-lied/perl/ch-2.pl @@ -0,0 +1,44 @@ +#!/usr/bin/env perl +# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu: +#============================================================================= +# ch-2.pl Perl Weekly Challenge 247 Task 2 Most Frequent Letter Pair +#============================================================================= +# You are given a string S of lower case letters 'a'..'z'. +# Write a script that finds the pair of consecutive letters in S that +# appears most frequently. If there is more than one such pair, choose +# the one that is the lexicographically first. +# Example 1 Input: $s = 'abcdbca' +# Output: 'bc' ('bc' appears twice in `$s`) +# Example 2 Input: $s = 'cdeabeabfcdfabgcd' +# Output: 'ab' +#============================================================================= +# Copyright (c) 2023, Bob Lied +#============================================================================= + +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; + +sub mflp($s) +{ + my %freq; + $freq{$_}++ for map { substr($s, $_, 2) } 0 .. (length($s)-2); + return (sort { $freq{$b} <=> $freq{$a} || $a cmp $b } keys %freq)[0]; +} + +sub runTest +{ + use Test2::V0; + + is( mflp("abcdbca"), 'bc', "Example 1"); + is( mflp("cdeabeabfcdfabgcd"), 'ab', "Example 2"); + + done_testing; +} -- cgit