From 6514f4e894ff38f2742ca1d806d35feda474ca25 Mon Sep 17 00:00:00 2001 From: Thomas Köhler Date: Mon, 20 Mar 2023 15:44:50 +0100 Subject: Add solution for week 209. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Thomas Köhler --- challenge-209/jeanluc2020/blog-1.txt | 1 + challenge-209/jeanluc2020/blog-2.txt | 1 + challenge-209/jeanluc2020/perl/ch-1.pl | 87 ++++++++++++++ challenge-209/jeanluc2020/perl/ch-2.pl | 202 +++++++++++++++++++++++++++++++++ 4 files changed, 291 insertions(+) create mode 100644 challenge-209/jeanluc2020/blog-1.txt create mode 100644 challenge-209/jeanluc2020/blog-2.txt create mode 100755 challenge-209/jeanluc2020/perl/ch-1.pl create mode 100755 challenge-209/jeanluc2020/perl/ch-2.pl diff --git a/challenge-209/jeanluc2020/blog-1.txt b/challenge-209/jeanluc2020/blog-1.txt new file mode 100644 index 0000000000..dee1c81e7b --- /dev/null +++ b/challenge-209/jeanluc2020/blog-1.txt @@ -0,0 +1 @@ +http://gott-gehabt.de/800_wer_wir_sind/thomas/Homepage/Computer/perl/theweeklychallenge-209-1.html diff --git a/challenge-209/jeanluc2020/blog-2.txt b/challenge-209/jeanluc2020/blog-2.txt new file mode 100644 index 0000000000..e324ea0d15 --- /dev/null +++ b/challenge-209/jeanluc2020/blog-2.txt @@ -0,0 +1 @@ +http://gott-gehabt.de/800_wer_wir_sind/thomas/Homepage/Computer/perl/theweeklychallenge-209-2.html diff --git a/challenge-209/jeanluc2020/perl/ch-1.pl b/challenge-209/jeanluc2020/perl/ch-1.pl new file mode 100755 index 0000000000..8451905f3d --- /dev/null +++ b/challenge-209/jeanluc2020/perl/ch-1.pl @@ -0,0 +1,87 @@ +#!/usr/bin/perl +# https://theweeklychallenge.org/blog/perl-weekly-challenge-209/#TASK1 +# +# Task 1: Special Bit Characters +# ============================== +# +# 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. +# +############################################################ +## +## discussion +## +############################################################ +# +# We walk the array from start to end. If the current element is 1, we +# also take the next one, decode into the character and go on. If the +# last character we found was an "a", we return 1, otherwise 0. + +use strict; +use warnings; + +special_bit_characters(1, 0, 0); +special_bit_characters(1, 1, 1, 0); + +sub special_bit_characters { + my @bits = @_; + print "Input: (" . join(", ", @bits) . ")\n"; + # the state we have consist of the last bit (either set to 1 or + # undef) and the current character (undef or one of a, b, c) + my $last_bit = undef; + my $char = undef; + foreach my $bit (@bits) { + # if the last bit was set, we either have a b or a c + if($last_bit) { + if($bit) { + $char = "c"; + } else { + $char = "b"; + } + # make sure we reset the state of the last bit so we're ready + # to read the next bit + $last_bit = undef; + } else { + # last bit was not set, so either we start a new 2-bits character + # or we have the 1-bit character "a" + if($bit) { + $last_bit = 1; + $char = undef; + } else { + $char = "a"; + } + } + } + # Now we just need to check whether the last character was the 1-bit + # character "a" or not + if($char eq "a") { + print "Output: 1\n"; + return 1; + } else { + print "Output: 0\n"; + return 0; + } +} diff --git a/challenge-209/jeanluc2020/perl/ch-2.pl b/challenge-209/jeanluc2020/perl/ch-2.pl new file mode 100755 index 0000000000..852a490a5d --- /dev/null +++ b/challenge-209/jeanluc2020/perl/ch-2.pl @@ -0,0 +1,202 @@ +#!/usr/bin/perl +# https://theweeklychallenge.org/blog/perl-weekly-challenge-209/#TASK2 +# +# Task 2: Merge Account +# ===================== +# +# 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"] ] +# +############################################################ +## +## discussion +## +############################################################ +# +# This is a bit a tricky one. When we walk through the input, +# we can either merge directly to a previous element in the +# output, or we have to append a new element to the output. +# Since corner cases are not considered, there are a few funny +# ones. What do we do if there is no common email address for +# two elements with the same name, but a third element in the +# list has an email address in common with both previous elements? +# We can then either merge with the first, or we could merge all +# three elements - since the task is unclear here, let's implement +# both solutions as alternatives + +use strict; +use warnings; +use Data::Dumper; + +my @accounts = ( + ["A", "a1\@a.com", "a2\@a.com"], + ["B", "b1\@b.com"], + ["A", "a3\@a.com", "a1\@a.com"] +); +merge_accounts(@accounts); +merge_accounts_full(@accounts); + +@accounts = ( + ["A", "a1\@a.com", "a2\@a.com"], + ["B", "b1\@b.com"], + ["A", "a3\@a.com"], + ["B", "b2\@b.com", "b1\@b.com"] +); +merge_accounts(@accounts); +merge_accounts_full(@accounts); + +@accounts = ( + ["A", "a1\@a.com", "a2\@a.com"], + ["B", "b1\@b.com"], + ["A", "a3\@a.com"], + ["B", "b2\@b.com", "b1\@b.com"], + ["A", "a3\@a.com", "a2\@a.com"], +); +merge_accounts(@accounts); +merge_accounts_full(@accounts); + +# helper function: merge the accounts in the given array +# this doesn't merge fully, only if an element already +# has a matching email address in a previous element +# returns the merged array +# This function only does the actual merging, nothing else +sub merge_accounts_ { + my $accounts = shift; + my $result = []; + foreach my $elem (@$accounts) { + my $did_merge = 0; + # if there is an element in the current result set + # that we can merge to, we do that, otherwise we'll + # just add a new element to the result + foreach my $i (0..$#$result) { + if (can_merge_to($elem, $result->[$i])) { + $result->[$i] = merge($result->[$i], $elem); + $did_merge = 1; + last; + } + } + push @$result, $elem unless $did_merge; + } + return $result; +} + +# helper function to do the actual merging +# Just add each email address to the first +# element unless it's there +# The name will also not be added because it's +# already there, no need for special treatment here +sub merge { + my ($elem1, $elem2) = @_; + my $seen; + map { $seen->{$_} = 1 } @$elem1; + foreach my $part (@$elem2) { + next if $seen->{$part}; + push @$elem1, $part; + } + return $elem1; +} + +# check whether we can merge two elements +# first, we need to check that name is the same +# then we need to find at least one matching email address +sub can_merge_to { + my ($elem1, $elem2) = @_; + my $seen; + map { $seen->{$_} = 1 } @$elem1; + my $name = $elem2->[0]; + return 0 unless $name eq $elem1->[0]; + foreach my $part (@$elem2) { + next if $part eq $name; + return 1 if $seen->{$part}; + } + return 0; +} + +# merge accounts from list when possible, not doing the deep +# re-merge if possible. This function does some output and +# otherwise calls merge_accounts_ for the actual work +sub merge_accounts { + my $accounts = [ @_ ]; + print "Input: ["; + foreach my $elem (@$accounts) { + print " [" . join(", ", @$elem) . "]\n"; + } + print "]\n"; + + my $merged = merge_accounts_($accounts); + + print "Output: ["; + foreach my $elem (@$merged) { + print " [" . join(", ", @$elem) . "]\n"; + } + print "]\n"; +} + +# this is the "full merge" option. We simply merge as before, +# but this time, as long as input and output of the actual +# merge step differ, we will start over with the current output +# as the new input. So we merge unless there is no more possibilty +# to merge anything +sub merge_accounts_full { + my $accounts = [ @_ ]; + print "Input: ["; + foreach my $elem (@$accounts) { + print " [" . join(", ", @$elem) . "]\n"; + } + print "]\n"; + + my $merged = merge_accounts_($accounts); + + while(is_same_deeply($accounts, $merged) == 0) { + $accounts = $merged; + $merged = merge_accounts_($accounts); + } + + print "Output: ["; + foreach my $elem (@$merged) { + print " [" . join(", ", @$elem) . "]\n"; + } + print "]\n"; +} + +# helper function +# check if two nested arrays have the same elements at the bottom +sub is_same_deeply { + my ($list1, $list2) = @_; + if(scalar(@$list1) != scalar(@$list2)) { + return 0; + } + # two empty lists are the same + return 1 unless @$list1; + foreach my $i (0..$#$list1) { + if(ref($list1->[$i]) ne ref($list2->[$i])) { + return 0; + } + if(ref($list1->[$i]) eq "ARRAY") { + return 0 unless is_same_deeply($list1->[$i], $list2->[$i]); + } + } + return 1; +} + -- cgit