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:

    local *get_chars=sub {
        #-- 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.

    local *compare_words=sub {
       #-- 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:

sub common_characters {
    #-- 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:

sub unequal_triplets {
    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

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