PWC 234
PWC 234
I tried to restrict to Perl 4 syntax for both challenges this week, as documented in Rex Swain's Perl 4 reference or the 1st edition of Programming perl. I do use nested subroutines, which I am not sure would actually work in Perl 4, though they comply with the syntax. My programs are tested on Perl 5.38. (The -l in the shebang line works only in Perl 5. The Perl 4 equivalent was -L012 in Unix, which is no longer available.)
As I have mentioned before, my aims in using the old syntax are just mild nostalgia plus to add a bit of additional challenge to the task. I know that this is not the most efficient or idiomatic way to do things today. But I should observe that it is really cool that I am able to write code using 30-year old syntax, and run it unmodified on the latest Perl 5.38. You cannot do this with Python 3 for example. This very deep backward compatibility is one of those unsung underappreciated beauties of Perl 5. In my opinion, it is a very cool thing indeed. I know that it is something that Perl has in common with say COBOL, or Microsoft Windows, or C, none of which are exactly geek chic. All are pretty solidly entrenched and pervasive in their domains though, whether one bemoans that or not, and if one thinks about it, so is Perl.
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 (Common Characters)
We are given a list of strings, and asked to extract the list of characters that are common to every string in the list. This includes repeated characters, so if "l" is repeated twice in every string in the list, it appears twice in the output list.
I use a helper sub-subroutine &get_chars to build a frequency table of each character in a string. Here it is:
#-- hash to get chars with frequency
local ($get_chars)=@_;
local %get_chars;
foreach (0 .. length($get_chars)-1) {
$get_chars{substr($get_chars,$_,1)}++;
}
%get_chars;
};
Another helper sub-subroutine &compare_words extracts the common characters in two strings. It calls &get_chars on each string to get the frequency table of characters, and then loops through the keys of one of the frequency tables, building an output string by concatenating (. dot operator) the characters that are keys of the other frequency table, repeated (x repeat operator) by the lower of the frequencies in the two frequency tables. Thus if 'm' occurs twice in the first string, and thrice in the second, the output would contain 'm'x2 or 'mm'. Here is &compare_words.
#-- compare two strings and return the common characters
#-- as a string
local (@compare_words)=@_[0..1];
local (%word1, %word2, $compare_words);
%word1=&get_chars($compare_words[0]);
%word2=&get_chars($compare_words[1]);
foreach (sort keys %word1) {
if (defined($word2{$_}) ){
local $num_chars=
( ($word2{$_} < $word1{$_}) ?
($word2{$_}) :
($word1{$_}) ) ;
$compare_words .= ($_ x $num_chars);
}
}
$compare_words;
};
Finally the outer subroutine &compare_words just loops through the array elements, at each stage calling &compare_words to compare the output of the previous &compare_words to the next string in the input list. Here it is:
#-- if just one element return it
(scalar(@_)==1) && (return $_[0]);
#-- helper sub subs
#-- back to trunk of subroutine
#-- store common chars in first two words in return value
#-- $common_characters
local $common_characters=&compare_words($_[0],$_[1]);
#-- if just 2 elements, we are through.
($#_ < 2) && (return $common_characters);
#-- If not, loop through the rest of the array, comparing
#-- the common characters string to the next element.
#-- At each stage, replace $common_characters with
#-- the characters it has in common with the next element.
foreach (2 .. $#_){
$common_characters = &common_characters($common_characters, $_[$_]);
}
#-- return
$common_characters;
}
Challenge 2 (Unequal Triplets)
We are given a list of positive integers. We are asked to identify the number of combinations of three sets of different indices for the list, such that every list item corresponding to those indices is a different number.
That is, given a list @list, find the number of triplets (i,j,k) such that $list[i] != $list[j] != $list[k].
Due to my decision to stick to Perl 4, I have to do this using an unidiomatic triple nested loop. (There may be a better way, but it doesn't occur to me right now.)
I first loop through the input list creating a frequency table of the unique elements. I next create a triple nested loop that goes through every combination of three unique elements from the input list. (This has to be done carefully to avoid repetition. I'll let my code given below speak for itself). For each of these triplets, we compute the number of combinations of indices that they represent by multiplying the frequencies of every element in the triplet. Thus if [1,2,3] is the triplet, 1 occurs twice in the input list, 2 occurs thrice in the input list, and 3 occurs once in the input list, the total number of combinations of indices would be 2 times 3 times 1.
Here is the code:
local (%unequal_triplets, $unequal_triplets);
foreach (@_) {
#-- input validation: only positive integers allowed
($_ > 0) || (die "Only positive integers allowed.");
#-- count the frequency
$unequal_triplets{$_}++;
}
local ($i, $j, $k); #-- counters
(scalar(keys(%unequal_triplets))<3) && (return 0);
#-- use parentheses so we don't have to worry about precedence
local $unequal_triplets=0; #-- return value
#-- loop through the unique elements
#-- 3 nested loops to enumerate triplets
I: foreach $i (keys %unequal_triplets){
J: foreach $j (keys %unequal_triplets){
($i==$j) && (next I);
K: foreach $k (keys %unequal_triplets){
( ($k==$j) || ($k==$i) ) && (next J);
#-- add product of frequencies of elements i, j and k
$unequal_triplets += $unequal_triplets{$i}*
$unequal_triplets{$j}*
$unequal_triplets{$k};
}
}
}
$unequal_triplets;
}
Comments