diff options
Diffstat (limited to 'challenge-209')
41 files changed, 2591 insertions, 62 deletions
diff --git a/challenge-209/0rir/raku/ch-1.raku b/challenge-209/0rir/raku/ch-1.raku new file mode 100644 index 0000000000..0cc411ea05 --- /dev/null +++ b/challenge-209/0rir/raku/ch-1.raku @@ -0,0 +1,136 @@ +#!/usr/bin/env raku +# :vim ft=raku sw=4 expandtab # 🦋 ∅∪∩∋∈∉ ≡ ≢ « » ∴ +use v6.d; +use lib $?FILE.IO.parent(2).add("lib"); +use Test; + +=begin comment +209-1: Special Bit Characters Submitted by: Mohammad S Anwar +Given an array of binary bits that ends with 0. + +Valid sequences in the bit string are: +[0] -decodes-to-> "a" +[1, 0] -> "b" +[1, 1] -> "c" + +Write a script to print 1 if the last character is an “a” otherwise print 0. + +Example 1 +Input: @bits = (1, 0, 0) +Output: 1 + +The given array bits can be decoded as 2-bits character (10) followed by 1-bit character (0). +Example 2 + +Input: @bits = (1, 1, 1, 0) +Output: 0 + +Possible decode can be 2-bits character (11) followed by 2-bits character (10) i.e. the last character is not 1-bit character. + +=end comment + +=begin comment +A […,0,0] indicates a final 'a'. +A […,1,0] is ambiguous. That _one_ can be considered the end of a sequence of +ones. The sequence's length being odd or even, determines if the one belongs +to a final 'b' or a penultimate 'c'. +=end comment + +constant $V-end = 'a'; + +my @Data = do for 1..10000 { + my $w = .base(3); + ($w ~~ tr/0..2/a..c/).Str; +} + +# validate input word +sub abc-a-valid( $str --> Bool ) { + so $str ~~ / ^ <[abc]>* $V-end $/; +} + +# convert a test word to array of 1's and 0's +sub abc-encode( $str is copy --> Array ) { + $str.=subst( 'c', '11', :g); + $str.=subst( 'b', '10', :g); + $str.=subst( 'a', '0', :g); + $str.comb.Array; +} + +enum State <SizeQ Small Large DoneQ Done>; + +# For empirical verification. Not the solution. +sub abc-decode ( @bit --> Str ) { + + # STATE vars + my $return; + my $idx = 0; + + my %transition = + SizeQ => -> { @bit[$idx] == 0 ?? "Small" !! "Large" }, # First state. + Small => -> { $return ~= 'a'; ++$idx; "DoneQ" }, + Large => -> { + $return ~= @bit[$idx+1] == 0 ?? 'b' !! 'c'; + die 'ilformed input' if $idx > @bit.end; + $idx += 2; + 'DoneQ'; + }, + DoneQ => -> { if $idx ≤ @bit.end { "SizeQ" } else { 'Done' }}, + Done => "End marker for the state machine.", + ; + + my $state = 'SizeQ'; + while $state ne 'Done' { + $state = %transition{$state}(); + } + $return; +} + +# calc correct answer +sub abc-expect( $str --> Bool) { + when $str ~~ / a $/ { True } + False; +} + +multi sub ends-with-a( @bit where @bit.end < 3 --> Bool ) { + given @bit { + # a, aa, ba, aaa, ca + when [[0], [0,0], [1,0,0], [0,0,0], [1,1,0],].any { True } + # b, c, ab, a,c + when [[1,0], [1,1], [0,1,0], [0,1,1], ].any { False } + # splat + when [ [], [1], [0,1], [0,0,1], [1,0,1], [1,1,1],].any { fail } + } +} + +multi sub ends-with-a( @bit --> Bool ) { + + fail if @bit.tail ≠ 0; + + return True if @bit[*-2] == 0; + + return so ( + @bit.end - 1 + - + ( @bit[0..*-2].first( * !~~ 1, :k, :end) // -1) + ) %% 2; +} + +my @Test = @Data.grep: * ~~ / a $ /; + +plan 2 × @Test; + +for @Test -> $in { + my $exp = abc-expect( $in); + my @bit = abc-encode( $in); + my $uncode = abc-decode( @bit); + is $uncode, $in, "$in to bits and back"; + is ends-with-a(@bit), $exp, "$uncode -> @bit[] -> $exp"; +} +done-testing; + +my @bit = 1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1, 0; + +say "\nInput: @bits = @bit[]\nOutput: ", &ends-with-a( @bit) ?? 1 !! 0; + +exit; + diff --git a/challenge-209/0rir/raku/ch-2.raku b/challenge-209/0rir/raku/ch-2.raku new file mode 100644 index 0000000000..90b9cae440 --- /dev/null +++ b/challenge-209/0rir/raku/ch-2.raku @@ -0,0 +1,125 @@ +#!/usr/bin/env raku +# :vim ft=raku sw=4 expandtab # 🦋 ∅∪∩∋∈∉ ≡ ≢ « » ∴ +use v6.d; +use Test; + +=begin comment +209-Task 2: Merge Account Submitted by: Mohammad S Anwar +Given an array of accounts i.e. name with list of email addresses, +merge the accounts where possible. Accounts can only be merged if +they have at least one email address in common. + +Example 1: + +Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"], + ["B", "b1@b.com"], + ["A", "a3@a.com", "a1@a.com"] ] + ] + +Output: [ ["A", "a1@a.com", "a2@a.com", "a3@a.com"], + ["B", "b1@b.com"] ] +Example 2: + +Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"], + ["B", "b1@b.com"], + ["A", "a3@a.com"], + ["B"m "b2@b.com", "b1@b.com"] ] + +Output: [ ["A", "a1@a.com", "a2@a.com"], + ["A", "a3@a.com"], + ["B", "b1@b.com", "b2@b.com"] ] + +=end comment + + +subset Accno of Any where m/ ^ <:Lu> \d \d $ /; +subset Addr of Any where m/^ (<:Ll> \d ** 3) | (<:Lu> ** 4) $/; + +sub dsay(*@a ) {;}; + +my @Data = + # a/c addr ... + [< A01 a010 a011 CCCC >], + [< A02 a020 a022 BBBB >], + [< A03 a030 >], + [ 'A04', ], + [< A07 BBBB >], + [< A08 a070 a071 >], + [< A09 a080 a081 CCCC>], + [< A10 a101 >], + [< A11 a111 CCCC>], +; + +sub MAIN () { + say "Input: @accounts = ["; + say " ", $_.raku for @Data; + say " ]"; + say "Output: ["; + say " ", $_.raku for combine-accounts( @Data); + say " ]"; +} + +# Combine all possible a/c. +sub combine-accounts( @database --> Array ) { + + my (%by-ac, %by-addr, %ac2expand, %ac2drop); + + # Hash each a/c. + for @database -> @d { + %by-ac{@d.head} = [ @d.tail(*-1)]; # XXX Simpler put all in values. + } + + # Invert a/c to key by address. + %by-addr.append: %by-ac.invert; + + for %by-addr.keys -> $k { + when %by-addr{ $k} ~~ Str { # Address has only one acct so + %by-addr{$k}:delete; # no work. + } + + my $key = choose-ac-to-expand( %by-addr{$k}); + %ac2expand{$key} = %by-addr{$k}.values.grep(* !~~ $key).Array; + + for %by-addr{$k}.values.grep(* !~~ $key).Array { + %ac2drop{ $_ }++ ; + } } + + my @expanded = merge-acs( %ac2expand, %by-ac); + for @expanded -> ( :key($k), :value($v) ) { + %by-ac{$k} = $v; + } + for %ac2drop.keys -> $k { + %by-ac{$k}:delete; + } + + my @new; + for %by-ac.keys.sort -> $k { + @new.push: [$k, |%by-ac{$k}] ; # | %by-ac{$k} ]; + } + return @new; +} + +# Merge all accts that need combining. +sub merge-acs( %keepers, %by-ac --> Array ) { + my @updated; + for %keepers.pairs -> $kp { + @updated.push: expand-ac( $kp, %by-ac); + } + return @updated; +} + +# Merge accounts into the a/c indicated by the Pair $keep. +sub expand-ac( $keep, %by-ac --> Pair ) { + my $key = $keep.key; + my @value = $keep.value.Array ; + + for [$key, | $keep.value] -> $pack-me { + @value.push: | %by-ac{$pack-me}; + } + $key => @value.unique.Array; +} + +# Choose which a/c to expand vs. consume. +sub choose-ac-to-expand( @ac --> Accno) { @ac.min( :by( &[leg])); } + + diff --git a/challenge-209/2colours/raku/ch-1.raku b/challenge-209/2colours/raku/ch-1.raku new file mode 100755 index 0000000000..3b4a2ac689 --- /dev/null +++ b/challenge-209/2colours/raku/ch-1.raku @@ -0,0 +1,17 @@ +#!/usr/bin/env raku + + +my token bit { <[01]> }; +subset BitList of Str where /^ '(' <bit>* % ',' ')' $/; + +sub MAIN(Str $bits) { + die 'Please supply a valid list of bits.' unless $bits.subst(/\s/, '', :g) ~~ BitList; + my Str() @bits = $<bit>; + die 'The last bit must be zero!' unless @bits[*-1] == 0; + my $bit-string = @bits.join; + $bit-string + .trans: <0 10 11> => <a b c> andthen + .substr(*-1) eq 'a' andthen + .Int + .say; +} diff --git a/challenge-209/2colours/raku/ch-2.raku b/challenge-209/2colours/raku/ch-2.raku new file mode 100755 index 0000000000..3a6ce5e96d --- /dev/null +++ b/challenge-209/2colours/raku/ch-2.raku @@ -0,0 +1,54 @@ +#!/usr/bin/env raku + +use Email::Valid; # zef install Email::Valid +my $email = Email::Valid.new; + +# Constraints: +# - the name can't have quotation marks + +my token name { '"' <( .*? )> '"' } +my token email { '"' <( .*? )> '"' <?{ $email.validate($/.Str) }> } +my token account { '[' <name> [ ',' <email>+ % ',' ]? ']' } +subset AccountList of Str where /^ '[' <account>* % ',' ']' $/; + +use MONKEY-TYPING; +augment class Array { + proto method unify-transitive is nodal {*} + multi method unify-transitive([]:) { [] } + multi method unify-transitive([@emails-head, **@rest]:) { + my @unified-rest = @rest.unify-transitive; + my @result; + @result.push: @emails-head; + for @unified-rest -> @emails-current { + given @result.head { + if $_ (&) @emails-current { + .append: keys(@emails-current (-) $_); + } + else { + @result.push: @emails-current; + } + } + } + @result + } +} + +sub build-account-str($name, @mails) { + my $mails-part = @mails.map('"' ~ * ~ '"').join(', '); + qq:to/END/.chomp + ["$name"{", $_" if .so given $mails-part}] + END +} + +sub MAIN(Str $accounts) { + die 'Please supply a valid list of accounts.' unless $accounts.subst(/\s/, '', :g) ~~ AccountList; + my @accounts <== + $<account>.map: { .<name>.Str => .<email>>>.Str }; + @accounts + .classify: *.key, as => *.value andthen + .duckmap: *.unify-transitive andthen + .map: {slip(.key X[&build-account-str] .value[])} andthen + .join: ', ' andthen + "[$_]" andthen + .say; +} diff --git a/challenge-209/athanasius/perl/Example_1.txt b/challenge-209/athanasius/perl/Example_1.txt new file mode 100644 index 0000000000..2cc2ad4af9 --- /dev/null +++ b/challenge-209/athanasius/perl/Example_1.txt @@ -0,0 +1,3 @@ +"A","a1@a.com","a2@a.com" +"B","b1@b.com" +"A","a3@a.com","a1@a.com" diff --git a/challenge-209/athanasius/perl/Example_1_answer.txt b/challenge-209/athanasius/perl/Example_1_answer.txt new file mode 100644 index 0000000000..b5f95b0c63 --- /dev/null +++ b/challenge-209/athanasius/perl/Example_1_answer.txt @@ -0,0 +1,2 @@ +"A","a1@a.com","a2@a.com","a3@a.com" +"B","b1@b.com" diff --git a/challenge-209/athanasius/perl/Example_2.txt b/challenge-209/athanasius/perl/Example_2.txt new file mode 100644 index 0000000000..50751d8755 --- /dev/null +++ b/challenge-209/athanasius/perl/Example_2.txt @@ -0,0 +1,4 @@ +"A","a1@a.com","a2@a.com" +"B","b1@b.com" +"A","a3@a.com" +"B","b2@b.com","b1@b.com" diff --git a/challenge-209/athanasius/perl/Example_2_answer.txt b/challenge-209/athanasius/perl/Example_2_answer.txt new file mode 100644 index 0000000000..1123c1be79 --- /dev/null +++ b/challenge-209/athanasius/perl/Example_2_answer.txt @@ -0,0 +1,3 @@ +"A","a1@a.com","a2@a.com" +"A","a3@a.com" +"B","b1@b.com","b2@b.com" diff --git a/challenge-209/athanasius/perl/Transitive.txt b/challenge-209/athanasius/perl/Transitive.txt new file mode 100644 index 0000000000..b830322e4b --- /dev/null +++ b/challenge-209/athanasius/perl/Transitive.txt @@ -0,0 +1,7 @@ +"A","a1@a.com","a2@a.com" +"B","b1@b.com" +"A","a3@a.com","a4@a.com" +"B","b2@b.com","b3@b.com" +"A","a4@a.com","a5@a.com" +"B","b2@b.com","b1@b.com" +"A","a5@a.com","a1@a.com" diff --git a/challenge-209/athanasius/perl/Transitive_answer.txt b/challenge-209/athanasius/perl/Transitive_answer.txt new file mode 100644 index 0000000000..ba7b303db9 --- /dev/null +++ b/challenge-209/athanasius/perl/Transitive_answer.txt @@ -0,0 +1,2 @@ +"A","a1@a.com","a2@a.com","a3@a.com","a4@a.com","a5@a.com" +"B","b1@b.com","b2@b.com","b3@b.com" diff --git a/challenge-209/athanasius/perl/ch-1.pl b/challenge-209/athanasius/perl/ch-1.pl new file mode 100644 index 0000000000..7f88a063be --- /dev/null +++ b/challenge-209/athanasius/perl/ch-1.pl @@ -0,0 +1,187 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 209 +========================= + +TASK #1 +------- +*Special Bit Characters* + +Submitted by: Mohammad S Anwar + +You are given an array of binary bits that ends with 0. + +Valid sequences in the bit string are: + + [0] -decodes-to-> "a" + [1, 0] -> "b" + [1, 1] -> "c" + +Write a script to print 1 if the last character is an “a” otherwise print 0. + +Example 1 + + Input: @bits = (1, 0, 0) + Output: 1 + + The given array bits can be decoded as 2-bits character (10) followed by 1-bit + character (0). + +Example 2 + + Input: @bits = (1, 1, 1, 0) + Output: 0 + + Possible decode can be 2-bits character (11) followed by 2-bits character (10) + i.e. the last character is not 1-bit character. + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2023 PerlMonk Athanasius # +#--------------------------------------# + +#=============================================================================== +=comment + +Interface +--------- +1. If no command-line arguments are given, the test suite is run. Otherwise: +2. If $VERBOSE is set to a true value, the required output (1 or 0) is followed + by the decoded text. + +=cut +#=============================================================================== + +use strict; +use warnings; +use Const::Fast; +use Test::More; + +const my $VERBOSE => 1; +const my $USAGE => +"Usage: + perl $0 <bits> + perl $0 + + <bits> A string of binary bits ending in 0\n"; + +#------------------------------------------------------------------------------- +BEGIN +#------------------------------------------------------------------------------- +{ + $| = 1; + print "\nChallenge 209, Task #1: Special Bit Characters (Perl)\n\n"; +} + +#=============================================================================== +MAIN: +#=============================================================================== +{ + my $args = scalar @ARGV; + + if ($args == 0) + { + run_tests(); + } + elsif ($args == 1) + { + my $bits = parse_command_line( $ARGV[ 0 ] ); + + printf "Input: \@bits = (%s)\n", join ', ', @$bits; + + my ($text, $output) = decode( $bits ); + + print "Output: $output\n"; + print "\nDecoded string: $text\n" if $VERBOSE; + } + else + { + error( "Expected 1 or 0 command line arguments, found $args"); + } +} + +#------------------------------------------------------------------------------- +sub decode +#------------------------------------------------------------------------------- +{ + my ($bits) = @_; + my $text; + + while (@$bits) + { + my $bit0 = shift @$bits; + + if ($bit0 == 0) + { + $text .= 'a'; + } + else + { + my $bit1 = shift @$bits; + + $text .= $bit1 == 0 ? 'b' : 'c'; + } + } + + return ($text, $text =~ / a $ /x ? 1 : 0); +} + +#------------------------------------------------------------------------------- +sub parse_command_line +#------------------------------------------------------------------------------- +{ + my ($bits) = @_; + + $bits =~ / ^ [01]* 0 $ /x + or error( 'Invalid input string' ); + + my @bits = split //, $bits; + + return \@bits; +} + +#------------------------------------------------------------------------------- +sub run_tests +#------------------------------------------------------------------------------- +{ + print "Running the test suite\n"; + + while (my $line = <DATA>) + { + chomp $line; + + my ($test_name, $input, $expected) = split / \| /x, $line; + + $test_name =~ s/ \s+ $ //x; + $input =~ s/ \s+ $ //x; + + my @bits = split //, $input; + my ($text, $out) = decode( \@bits ); + my $got = "$text=$out"; + + is $got, $expected, $test_name; + } + + done_testing; +} + +#------------------------------------------------------------------------------- +sub error +#------------------------------------------------------------------------------- +{ + my ($message) = @_; + + die "ERROR: $message\n$USAGE"; +} + +################################################################################ + +__DATA__ +Example 1|100 |ba=1 +Example 2|1110 |cb=0 +Longer |11101001101000|cbbacabaa=1 diff --git a/challenge-209/athanasius/perl/ch-2.pl b/challenge-209/athanasius/perl/ch-2.pl new file mode 100644 index 0000000000..760eebd716 --- /dev/null +++ b/challenge-209/athanasius/perl/ch-2.pl @@ -0,0 +1,247 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 209 +========================= + +TASK #2 +------- +*Merge Account* + +Submitted by: Mohammad S Anwar + +You are given an array of accounts i.e. name with list of email addresses. + +Write a script to merge the accounts where possible. The accounts can only be +merged if they have at least one email address in common. + +Example 1: + + Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"], + ["B", "b1@b.com"], + ["A", "a3@a.com", "a1@a.com"] ] + ] + + Output: [ ["A", "a1@a.com", "a2@a.com", "a3@a.com"], + ["B", "b1@b.com"] ] + +Example 2: + + Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"], + ["B", "b1@b.com"], + ["A", "a3@a.com"], + ["B", "b2@b.com", "b1@b.com"] ] + + Output: [ ["A", "a1@a.com", "a2@a.com"], + ["A", "a3@a.com"], + ["B", "b1@b.com", "b2@b.com"] ] + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2023 PerlMonk Athanasius # +#--------------------------------------# + +#=============================================================================== +=comment + +Interface +--------- +If no command-line arguments are given, the test suite is run. + +Assumptions +----------- +1. Accounts OF THE SAME NAME can be merged only if they have at least one email + address in common. +2. "Having an email address in common" is a transitive relation, so two accounts + with the same name but with no addresses in common can be merged if each has + an address in common with (say) a third account of the same name. + +Note +---- +No attempt is made to verify the format of email addresses. + +=cut +#=============================================================================== + +use strict; +use warnings; +use Const::Fast; +use Set::Scalar; +use Test::More; +use Text::CSV; + +const my $INDENT => ' ' x 8; +const my $USAGE => +"Usage: + perl $0 <file> + perl $0 + + <file> Name of accounts file\n"; + +#------------------------------------------------------------------------------- +BEGIN +#------------------------------------------------------------------------------- +{ + $| = 1; + print "\nChallenge 209, Task #2: Merge Account (Perl)\n\n"; +} + +#=============================================================================== +MAIN: +#=============================================================================== +{ + my $args = scalar @ARGV; + + if ($args == 0) + { + run_tests(); + } + elsif ($args == 1) + { + my $accounts = read_accounts_file( $ARGV[ 0 ] ); + + print format_accounts( "Input: \@accounts", $accounts ), "\n"; + + my $merged = merge_accounts( $accounts ); + + print format_accounts( "Output: \@merged", $merged ); + } + else + { + error( "Expected 1 or 0 command line arguments, found $args" ); + } +} + +#------------------------------------------------------------------------------- +sub merge_accounts +#------------------------------------------------------------------------------- +{ + my ($accounts) = @_; + my (%name2accounts, @merged); + + for my $account (@$accounts) + { + my ($name, @addresses) = @$account; + push @{ $name2accounts{ $name } }, \@addresses; + } + + for my $name (sort keys %name2accounts) + { + L_LOOP: + { + my $accounts = $name2accounts{ $name }; + + for my $i (0 .. $#$accounts - 1) + { + my $s = Set::Scalar->new( @{ $accounts->[ $i ] } ); + + for my $j ($i + 1 .. $#$accounts) + { + my $t = Set::Scalar->new( @{ $accounts->[ $j ] } ); + my $int = $s->intersection( $t ); + + if ($int->size > 0) + { + $accounts->[ $i ] = [ sort $s->union( $t )->members ]; + splice @$accounts, $j, 1; + redo L_LOOP; + } + } + } + + push @merged, [ $name, @$_ ] for @$accounts; + } + } + + return \@merged; +} + +#------------------------------------------------------------------------------- +sub read_accounts_file +#------------------------------------------------------------------------------- +{ + my ($filename) = @_; + -e $filename or error( qq[File "$filename" not found] ); + + my @accounts; + my $csv = Text::CSV->new( + { + allow_loose_quotes => 1, + auto_diag => 1, + binary => 1, + } + ); + + open( my $fh, '<', $filename ) + or die "Cannot open file $filename for reading, stopped"; + + while (my $row = $csv->getline( $fh )) + { + push @accounts, $row; + } + + close $fh + or die "Cannot close file $filename, stopped"; + + return \@accounts; +} + +#------------------------------------------------------------------------------- +sub format_accounts +#------------------------------------------------------------------------------- +{ + my ($header, $accounts) = @_; + + return sprintf "$header =\n%s[\n%s\n%s]\n", + $INDENT, + join + ( |