PWC 247

PWC 247

Two easy challenges this week. I attempt to do both using only the core Perl 5 syntax inherited from Perl 4. (Update and disclaimer: These programs will not work on Perl 4 as I discovered later when I found and installed a Perl 4.019 executable. For one thing, the ability to assign a subroutine to a locally scoped typeglob was not available in Perl 4.)

Challenge 1 (Secret Santa)

We are given a list of surnames, some of them repeated (representing different members of the same family). We are asked to create a scheme indicating who in the list gives gifts to who else, avoiding family members giving gifts within the family if possible.

I go through the input list using a hash to count the number of occurrences of each surname, and then append the hash count to the surname and store this in another list say @secret_santa, so that for example the second occurrence of 'Anwar' is recorded as 'Anwar_2'.

I then sort the @secret_santa list twice in opposite directions (ascending and descending) storing the results in different lists, and then pair the names at the same index in the respective sorted lists. For example, the first item in the list sorted in ascending order gives a gift to the first item in the list sorted in descending order.

It's not foolproof, because in one of the test examples, a person gives a gift to themself. This is not ruled out by the task spec though, so I let it stand. In fact, the system directly leads to a multiple-person surname right in the middle of the sorted lists giving presents within their family, and if there is an odd number of items in the list, the middle person in the list gives a present to themself.  Good enough I think. While it systematically leads to one family giving presents within their family, in situations when this could be avoided by some other assignments, if I am correct, it also ensures that at most only one family does so.

One idea for a fix (not implemented) is to insert a dummy surname that would take the middle place, and then harmlessly assign the dummy surname to give non-existent presents within its non-existent family. One would have to do this before the initial sorting. So one would have to find the surname in the lexicographic middle of the list and then create and insert a surname that takes its place. This fix does not always work. For example, it would not fix the test example where there are three persons with two in the same family.

The task description does mention that the assignment should be "random" which if interpreted in terms of everyday non-technical usage could be any mechanical system that does not suffer from any subjective human biases (like my solution). If we require randomness in a more technical sense, we can extend the algorithm by inserting a random number at the start of each surname string before the initial sorting, say "Anwar" becomes "0.525355840874003_Anwar". I have not attempted to implement this. 

Here is the code, along with a small custom sub to print a hash:

local *secret_santa=sub {
    local (%secret_santa,@secret_santa);
    foreach (@_) {
        $secret_santa{$_}++;
        push @secret_santa, $_."_".$secret_santa{$_};
    }
    %secret_santa=();
    {
        local (@sorted_1, @sorted_2);
        @sorted_1=sort {$a cmp $b} @secret_santa;
        @sorted_2=sort {$b cmp $a} @secret_santa;
        foreach (0 .. $#secret_santa) {
            $secret_santa{$sorted_1[$_]} = $sorted_2[$_];
        }
    }
    return %secret_santa;
};

local *print_hash=sub {
    local %_=@_;
    foreach (sort keys %_){
        print $_," => ", $_{$_};
    }
};

Challenge 2 (Most Frequent Letter Pair)

We are asked to slide through a string counting how many times each two-character sub-string occurs, and then return the sub-string with the highest count. If there are more than one such sub-string, we return the first one in lexicographic (dictionary) order.

I use a hash to count the occurrences of each sub-string, and then use a sort on the hash keys to return the key which has the maximum value (or the earliest such key in lexicographic order).

Here is the code:

local *most_frequent_letter_pair = sub {
    local ($s)=@_;
    local %s;
    foreach (0 .. (length($s)-2)) {
        $s{substr($s,$_,2)}++;
    }
    return (sort { ($s{$b} <=> $s{$a}) || ($a cmp $b)} keys %s) [0];
};


Comments

Post a Comment

Popular posts from this blog

PWC 258

PWC 258 Last week (#257) I finished challenge 2 and my blog post for challenge 257 late last week, so had only submitted challenge 1. Here is my blog post for PWC 257 , including the full code for my challenge 2 solution. This week, I have done both challenges in perl 4.019 on DOSBOX. Both scripts also work fine on the latest Perl 5.38. I also did the challenges in Raku, where they are one-liners.  Challenge 1 (Count Even Digits Number) We are given a list of integers, and asked to count the number of elements whose base-10 representation has an even number of digits. In Raku , this is a one-liner. Here it is: raku -e 'say +@*ARGS.grep({$_.chars %% 2})' $@ It could be a one-liner in Perl 4 too, but since I run it on DOSBOX, my script would not be a bash shell script. Here is the short subroutine that does the job.  sub count_even_digits {  scalar( grep( ((length($_) % 2) == 0), @_) ); } The full code is here . Challenge 2 (Sum of values) We are given an integer k  and a list in
Read more

PWC 249

PWC 249 Challenge 1 (Equal pairs) We are given a list of integers with an even number of elements. We are asked to check if the list can be completely divided into sub-lists of size 2 with each sub-list containing the same integer repeated, like say (2,2). If so, we are asked to return the list of such sub-lists. This is straightforward in Perl 5. I use modern conveniences this time, though it could be done using only primitive Perl 4 syntax. Here is my subroutine. It returns a list of array references. local *equal_pairs = sub {     #-- return () if input is of odd length     ((scalar(@_) % 2) > 0) && (return ());          #-- count number of occurrences of each element using a hash     local %_ = ();     map {$_{$_}++} @_;          #-- if any element occurs an odd number of times, return ()     (grep {($_{$_} % 2) > 0} keys %_) && (return ());          #-- loop thru %_ keys, returning pairs of such keys     map {         my $k=$_;         my $num_pairs=( ($_{$k}
Read more

PWC 253

PWC 253 I do both challenges this week using old software on DOSBOX: perl 4.019, and for comparison, also python 1.4 beta. My solutions also work on the current versions of Perl 5 (5.38) and Python 2 (2.7.18) respectively. Challenge 1 (Split Strings) Links to code: perl4.019 python1.4b We are given a list of strings, and a single character say sep . We are asked to return the list, with the strings split into component substrings using sep as a separator. We should not include any empty strings in the output. In perl 4, I first stick a backslash in front of the separator character, so that it is escaped if entered in a regex. This is because the perl split function takes a regex as its first argument indicating the separator. If we have a character like '$' or ',', we want to escape it so that it is read literally when parsing the regex. Here is the key subroutine:   sub split_strings {  local ($separator, @words)=@_;  local (@retval)=(); #array to be returned  #  #--
Read more