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];
};