Perl Weekly Challenge 083

Perl Weekly Challenge 083


Part 1


You are given a string $S with 3 or more words. Write a script to find the length of the string except the first and last words ignoring whitespace.


Solution



use strict;
use warnings;
##
# You are given a string $S with 3 or more words.
# Write a script to find the length of the string 
# except the first and last words ignoring whitespace.
##
sub count_most_words{
    my ($s) = @_;
    my $count = 0;
    my @a = split(/\s/, $s);
    map {$count += tr/a-zA-Z//d} @a[1 .. (@a - 2)];
    return $count;
}

MAIN:{
    my $S;
    $S = "The Weekly Challenge";
    print "$S --> " . count_most_words($S) . "\n";
    $S = "The purpose of our lives is to be happy";
    print "$S --> " . count_most_words($S) . "\n";
}

Sample Run



$ perl perl/ch-1.pl
The Weekly Challenge --> 6
The purpose of our lives is to be happy --> 23

Notes


Anytime I need to count characters I immediately think of tr. tr will, of course, do character replacements but it’s return value is the number of characters which have been effected. Here with the d option the matching characters are just deleted. This code would work exactly just as well with the d but I figured it’d be actually less confusing to have it there and make it more clear what it was doing.


Part 2


You are given an array @A of positive numbers. Write a script to flip the sign of some members of the given array so that the sum of the all members is minimum non-negative.



use strict;
use warnings;
##
# You are given an array @A of positive numbers.
# Write a script to flip the sign of some members 
# of the given array so that the sum of the all 
# members is minimum non-negative.
##
sub try_all_flips{
    my(@a) = @_;
    my @minimum = (undef, undef, []); 
    for my $i (0 .. (2**(@a) - 1)){
        my $b = sprintf("%0" . @a . "b", $i); 
        my @b = split(//, $b);
        my $flip_count = 0;
        map {$flip_count++ if $_ == 1} @b;
        my @f;
        for my $i (0 .. (@b - 1)){
            if($b[$i] == 1){
                push @f, (-1) * $a[$i];
            }
            else{
                push @f, $a[$i];
            }
        }
        my $sum = unpack("%32I*", pack("I*", @f)); 
        if(!defined($minimum[0]) || ($sum <= $minimum[0] && $sum >= 0)){
            if(defined($minimum[0]) && $sum == $minimum[0] && $flip_count < $minimum[1]){
                $minimum[0] = $sum;
                $minimum[1] = $flip_count;
                $minimum[2] = \@f;
            }
            elsif(!defined($minimum[0])){
                $minimum[0] = $sum;
                $minimum[1] = $flip_count;
                $minimum[2] = \@f;
            }
            elsif($sum < $minimum[0]){
                $minimum[0] = $sum;
                $minimum[1] = $flip_count;
                $minimum[2] = \@f;
            }
        }
    }
    return @minimum;
}

MAIN:{
    my @A;
    my @minimum;
    @A = (3, 10, 8);
    @minimum = try_all_flips(@A);
    print "[". join(", ", @A) . "] --> ";
    print  " [". join(", ", @{$minimum[2]}) . "] = " . $minimum[0] ."\n";
    @A = (12, 2, 10);
    @minimum = try_all_flips(@A);
    print "[". join(", ", @A) . "] --> ";
    print  " [". join(", ", @{$minimum[2]}) . "] = " . $minimum[0] ."\n";
}

Sample Run



$ perl perl/ch-2.pl
[3, 10, 8] -->  [3, -10, 8] = 1
[12, 2, 10] -->  [-12, 2, 10] = 0

Notes


This is a brute force approach. I use the same method for generating all combinations that I used in Challenge 077 with the variation that here I use the generated combination to determine which elements of the list are to be flipped. After calculating the sum of each new list (with flipped elements) I check to see if this is a new minimum positive value and, if so, if it has been done with fewer flips.

Perl Weekly Challenge 082

Perl Weekly Challenge 082

Part 1


You are given 2 positive numbers $M and $N. Write a script to list all common factors of the given numbers.


Solution



use strict;
use warnings;
##
# You are given 2 positive numbers $M and $N.
# Write a script to list all common factors of the given numbers.
##
sub factor{
    my($n) = @_;
    my @factors = (1);
    foreach my $j (2..sqrt($n)){
        push @factors, $j if $n % $j == 0;
        push @factors, ($n / $j) if $n % $j == 0 && $j ** 2 != $n;
    }    
    return @factors;  
}

sub common_factors{
    my($m, $n) = @_;
    my @common_factors = grep { my $f = $_; grep { $f == $_ } @{$n}} @{$m};
    return @common_factors;
}


MAIN:{
    my $M = 12;
    my $N = 18;
    my @m_factors = factor($M);
    my @n_factors = factor($N);
    print "(" . join(",", common_factors(\@m_factors, \@n_factors)) . ")\n";
}

Sample Run



$ perl perl/ch-1.pl
(1,2,6,3)

Notes


I have used sub factor previously, back in Challenge 008. The most interesting thing in this solution is probably the nested grep’s. In order to nest them properly you need to create a local variable to hold the element being examined in the outer grep block. Here I use $f. Although we need just two grep’s here this trick can be used to nest them more deeply.


Part 2


You are given 3 strings; $A, $B and $C. Write a script to check if $C is created by an interleaving of $A and $B. Print 1 if check is success otherwise 0.



use strict;
use warnings;
##
# You are given 3 strings; $A, $B and $C.
# Write a script to check if $C is created by interleave $A and $B.
# Print 1 if check is success otherwise 0.
##
sub find_remove{
    my($s, $x) = @_;
    my $i = index($s, $x);
    if($i != -1){
        substr $s, $i, length($x), "";
        return $s;
    }
    return undef;
}
MAIN:{
    my $A = "XY";
    my $B = "X";
    my $C = "XXY";
    my $s = find_remove($C, $A);
    if($s && $s eq $B){
        print "1\n";
        exit;
    }
    else{
        $s = find_remove($C, $B);
        if($s && $s eq $A){
            print "1\n";
            exit;
        }
    }
    print "0\n";
}

Sample Run



$ perl perl/ch-2.pl
1

Notes


I believe this is the most straightforward way of tackling this problem. By checking for both $A and $B as substrings and removing them if found we can determine if there was an interleaving by checking to see if the other remains.

Perl Weekly Challenge 081

Perl Weekly Challenge 081

Part 1


You are given 2 strings, $A and $B. Write a script to find out common base strings in $A and $B.


Solution



use strict;
use warnings;
##
# You are given 2 strings, $A and $B.
# Write a script to find out common base strings in $A and $B.
## 
use boolean;

sub contains{
    my($s0) = @_;
    return sub{
        my($s) = @_;
        return [true, $s0] if($s =~ m/^($s0)+$/g);
        return [false, $s0];
    }
}

sub make_checks{
    my($s) = @_;
    my @letters = split(//, $s);
    my @checks;
    for my $i (0 .. (int(@letters/2 - 1))){
        push @checks, contains(join("", @letters[0 .. $i]));
    }
    return @checks;
}

MAIN:{
    my($A, $B);
    #$A = "aaaaaaa";
    #$B = "aaaaaaaaaaaaaaaaaa";
    $A = "abcdabcd";
    $B = "abcdabcdabcdabcd";
    my @checks = make_checks($A);
    for my $check (@checks){
        if($check->($A)->[0] && $check->($B)->[0]){
            print $check->($A)->[1] . "\n";
            exit;
        }
    }
}

Sample Run


$ perl perl/ch-1.pl
abcdabcd, abcdabcdabcdabcd --> (abcd abcdabcd)
aaa, aa --> (a)

Notes


I used a similar technique to what I used in Challenge 003 and Challenge 004 where I create an array of anonymous functions which each check different substrings. The functions are created using what is called currying whereby we pass in a parameter (or multiple parameters if we needed to!) to a function which creates a closure around those parameters and returns a new function. This is, I admit, not all that necessary! I repeat the method though out of a sense of nostalgia. We are now on Challenge 081!


Part 2


You are given file named input. Write a script to find the frequency of all the words. It should print the result as first column of each line should be the frequency of the word followed by all the words of that frequency arranged in lexicographical order. Also sort the words in the ascending order of frequency.



use strict;
use warnings;
##
# You are given file named input.
# Write a script to find the frequency of all the words.
# It should print the result as first column of each line should be the frequency of the 
# word followed by all the words of that frequency arranged in lexicographical order. Also 
# sort the words in the ascending order of frequency.
##
MAIN:{
    my %counts;
    my %count_words;
    my $s;
    {    local $/;
         $s = ;
    }
    $s =~ s/'s//g;
    $s =~ tr/."(),//d;
    $s =~ tr/-/ /;
    my @words = split(/\s+/, $s);
    for my $word (@words){
        $counts{$word}++;
    }
    for my $k (keys %counts){
        my $count = $counts{$k};
        push @{$count_words{$count}}, $k;
    }
    for my $k (sort keys %count_words){
        print $k . "\t" . join(" ",  sort {$a cmp $b} @{$count_words{$k}}) . "\n";
    }
}


__DATA__ 
West Side Story

The award-winning adaptation of the classic romantic tragedy "Romeo and
Juliet". The feuding families become two warring New York City gangs,
the white Jets led by Riff and the Latino Sharks, led by Bernardo. Their
hatred escalates to a point where neither can coexist with any form of
understanding. But when Riff's best friend (and former Jet) Tony and
Bernardo's younger sister Maria meet at a dance, no one can do anything
to stop their love. Maria and Tony begin meeting in secret, planning to
run away. Then the Sharks and Jets plan a rumble under the
highway--whoever wins gains control of the streets. Maria sends Tony to
stop it, hoping it can end the violence. It goes terribly wrong, and
before the lovers know what's happened, tragedy strikes and doesn't stop
until the climactic and heartbreaking ending.

Sample Run


$ perl perl/ch-2.pl
1   But City It Jet Juliet Latino New Romeo Side Story Their Then West York adaptation any anything at award away become before begin best classic climactic coexist control dance do doesn't end ending escalates families feuding form former friend gains gangs goes happened hatred heartbreaking highway hoping in know love lovers meet meeting neither no one plan planning point romantic rumble run secret sends sister streets strikes terribly their two under understanding until violence warring what when where white whoever winning wins with wrong younger
2   Bernardo Jets Riff Sharks The by it led tragedy
3   Maria Tony a can of stop
4   to
9   and the

Notes


I have to admit that sometimes, even after many years of using Perl, that if I don’t use a certain feature often enough that I end up getting a little surprised. The surprise here is that Perl is clever enough to know that if I am trying a push onto a hash value which is undef, such as when I first do a push @{$count_words{$count}}, $k; for a new value of $k, that a new array is created. No need to check for undef and create a new one manually. This is called autovivification and while a very common thing in Perl for whatever reason it managed to catch me a little by surprise this time around. Probably due to my working a lot in other languages recently that don;t have this feature! Gabor has a nice writeup on autovivification for anyone interested in reading more.

Perl Weekly Challenge 080

Part 1



use strict;
use warnings;
##
# You are given an unsorted list of integers @N.
# Write a script to find out the smallest positive number missing.
##
sub least_missing{
    my(@numbers) = @_;
    @numbers = sort @numbers;
    for my $i ($numbers[0] .. $numbers[@numbers - 1]){
        my @a = grep { $_ == $i } @numbers;
        return $i if(!@a && $i > 0);
    }
    return undef;
}

MAIN:{
    my @N;
    @N = (5, 2, -2, 0);
    my $least_missing = least_missing(@N);
    print "The least mising number from (" .
        join(",", @N) . ") is $least_missing\n";
    @N = (1, 8, -1);
    $least_missing = least_missing(@N);
    print "The least mising number from (" .
        join(",", @N) . ") is $least_missing\n";
    @N = (2, 0, -1);
    $least_missing = least_missing(@N);
    print "The least mising number from (" .
        join(",", @N) . ") is $least_missing\n";
}

Sample Run


$ perl perl/ch-1.pl
The least mising number from (5,2,-2,0) is 1
The least mising number from (1,8,-1) is 2
The least mising number from (2,0,-1) is 1

Notes


The list is given in arbitrary order so the first thing to do is to sort it. Once in sorted order iterate from the least number to the highest, incrementing by one at each step. Perl makes this easy with the range (aka flip-flop) operator. Each each iteration see if the current number is from the original list or not and if not, then if it is the smallest positive number not yet seen, which really just means the first positive number not from the original list.


As I am writing this I realize that it’d make sense to use grep to remove all the negative numbers from the list before even bothering to sort them. If the list were presented as, say, 1 million negative numbers and then three positive ones why waste doing anything with all the negatives!


Part 2



use strict;
use warnings;
##
# You are given rankings of @N candidates.
# Write a script to find out the total candies needed for all candidates. 
# You are asked to follow the rules below:
#     a) You must given at least one candy to each candidate.
#     b) Candidate with higher ranking get more candies than their immediate
#        neighbors on either side.
##
sub count_candies{
    my(@candidates) = @_;
    my $candies = @candidates;
    for my $i (0 .. (@candidates - 1)){
        if($candidates[$i - 1]){
            $candies++ if $candidates[$i] > $candidates[$i - 1];
        }   
        if($candidates[$i + 1]){
            $candies++ if $candidates[$i] > $candidates[$i + 1];
        }
    }
    return $candies;
}


MAIN:{
    my @N;
    my $number_candies;
    @N = (1, 2, 2);
    $number_candies = count_candies(@N);
    print "The number of candies for (" .
        join(",", @N) . ") is $number_candies\n";
    @N = (1, 4, 3, 2);
    $number_candies = count_candies(@N);
    print "The number of candies for (" .
        join(",", @N) . ") is $number_candies\n";
}

Sample Run


$ perl perl/ch-2.pl
The number of candies for (1,2,2) is 4
The number of candies for (1,4,3,2) is 7

Notes


I don’t think there are any surprises in this approach. In fact, I could not think of a better way, in terms of efficiency, than this. Still, this is not exactly exciting code to read!

Perl Weekly Challenge 079

Part 1


You are given a positive number $N. Write a script to count the total number of set bits of the binary representations of all numbers from 1 to $N and return $total_count_set_bit % 1000000007.


Solution


“ch-1.pl”


Sample Run


$ perl perl/ch-1.pl
5 % 1000000007 = 5
4 % 1000000007 = 4


Notes


The approach here is to continuously shift bits off to the right, checking to see if the bit about to be shifted off is set or not. This is a pretty standard pattern and it looks pretty much the same in C++ and Prolog too!


Part 2


You are given an array of positive numbers @N. Write a script to represent it as Histogram Chart and find out how much water it can trap.


“ch-2.pl”


Sample Run



“ch-2.pl output”


Notes


This is one of the more fun sorts of problems that come up in these challenges! It is somewhat similar to the “leader problem” from last week in that we are given an array of numbers and need to do a similar set of look ahead comparisons. Here we look ahead in the array to determine if what I call buckets exist. Whatever buckets are found are then used to compute the total volume as specified.


References


https://users.cs.cf.ac.uk/Dave.Marshall/PERL/node36.html

Perl Weekly Challenge 078

Part 1


You are given an array @A containing distinct integers. Write a script to find all leader elements in the array @A. Print (0) if none found.


Solution


“ch-1.pl”


Sample Run

$ perl perl/ch-1.pl 6
@A = (9,10,7,5,6,1)
Leaders = (10,7,6,1)
@A = (3,4,5)
Leaders = (5)


Notes


The approach here is to just repeating the checks for smaller elements. Nothing too fancy. In fact, I actually thought that there might be room for some fun and over engineered way of doing this but I couldn’t really come up with anything that wouldn’t just be obfuscated!


Part 2


You are given array @A containing positive numbers and @B containing one or more indices from the array @A. Write a script to left rotate @A so that the number at the first index of @B becomes the first element in the array. Similary, left rotate @A again so that the number at the second index of @B becomes the first element in the array.


“ch-2.pl”


Sample Run

$ perl perl/ch-2.pl
@A = (10,20,30,40,50)
@B = (3,4)
Rotations:
    [40,50,10,20,30]
    [50,10,20,30,40]
@A = (7,4,2,6,3)
@B = (1,3,4)
Rotations:
    [4,2,6,3,7]
    [6,3,7,4,2]
    [3,7,4,2,6]


Notes


Another straight forward one. For each value in @B I shift and push the respective number of times.

Perl Weekly Challenge 076

I did this week's Perl Weekly Challenge in both Perl and Prolog. The Prolog solutions were good practice in shaking the rust off my logic programming but I won't discuss them here, to keep things short. The code for the Prolog solutions for Part 1 and Part 2 are on GitHub. 

Part 1

You are given a number $N. Write a script to find the minimum number of prime numbers required, whose summation gives you $N. For the sake of this task, please assume 1 is not a prime number.

For this solution I used a pre-computed list of the first 1000 prime numbers. Larger pre-computed lists are available and of course computing them directly is always an option too! For the purposes of this challenge it seemed a pre-computed list would be OK.

Code

ch-1.pl (with list of pre-computed primes cropped)
ch-1.pl (with list of pre-computed primes cropped)

Sample Run

$ perl perl/ch-1.pl 9
7 + 2 = 9

$ perl perl/ch-1.pl 87
83 + 2 + 2 = 87

Part 2

Write a script that takes two file names. The first file would contain word search grid as shown below. The second file contains list of words, one word per line. You could even use local dictionary file.

Print out a list of all words seen on the grid, looking both orthogonally and diagonally, backwards as well as forwards.

I opted to hard code the grid and load a small dictionary file. This file was obtained from http://www-personal.umich.edu/~jlawler/wordlist.html and contains 60,000 of the most common english words. Ultimately this yield a lot of awkward looking two and three letter words which, frankly, I do not personally consider all that common. I used the full dictionary but filter the results to only words with 4 or more letters.

ch-2.pl (with some utility functions cropped)
ch-2.pl (with some utility functions cropped)

The approach is straightforward:

  • Create arrays of all diagonals, columns, rows, etc of the grid.
  • Search for all dictionary words (forward and reverse) from all the grid arrays.
  • Filter out words with less than 4 letters. Many of these are very uncommon.
  • Sort and display the found words.

Sample Run

$ perl perl/ch-2.pl
Found the following words: align,alls,ante,arare,aras,aras,argos,baas,bide,blunt,bosc,broad,buff,butea,cart,cess,cold,cord,demi,depart,departed,doth,dust,ebro,enter,etna,eves,filch,garlic,gila,goat,gram,grieve,grit,hani,hazard,heed,laic,lien,luge,lune,mali,malign,malignant,mall,mein,mero,midst,need,oats,ough,ought,ovary,part,parte,parted,quash,rape,rara,rare,rast,road,roccus,ruse,sara,sara,shed,shrine,slag,slug,social,spasm,spasmodic,succor,succors,theorem,togo,trap,tsar,vary,virus,visa,wigged,zing

All Combinations Equal to a Sum in Perl and Prolog

A problem that comes up surprisingly often is that we want to determine lists of numbers which sum to some given number S.

For example, let's look at Perl Weekly Challenge 075

You are given a set of coins @C, assuming you have infinite amount of each coin in the set.

Write a script to find how many ways you make sum $S using the coins from the set @C.

Example:
Input:     
   @C = (1, 2, 4)     
   $S = 6  
Output: 6
There are 6 possible ways to make sum 6.
a) (1, 1, 1, 1, 1, 1)
b) (1, 1, 1, 1, 2)
c) (1, 1, 2, 2)
d) (1, 1, 4)
e) (2, 2, 2)
f) (2, 4)

Such a problem is a nice application for a logic programming approach!

Here is a first attempt with a pure Prolog solution (with SWI-Prolog).

ch-1.p
ch-1.p

Sample Run

$ swipl -s prolog/ch-1.p -g main

[[1,1,1,1,1,1],[2,1,1,1,1],[1,2,1,1,1],[1,1,2,1,1],[2,2,1,1],[4,1,1],[1,1,1,2,1],[2,1,2,1],[1,2,2,1],[1,4,1],[1,1,1,1,2],[2,1,1,2],[1,2,1,2],[1,1,2,2],[2,2,2],[4,2],[1,1,4],[2,4]]

We have some duplicate solutions to clean up, but since this is a Perl centric challenge let's do it in Perl and while we're at it, we'll also have Perl handle the input and output.

ch-1.pl
ch-1.pl

Sample Run

$ perl perl/ch-1.pl 6 "1,2,4"
(1,1,1,1,2)
(1,1,4)
(1,1,1,1,1,1)
(1,1,2,2)
(2,2,2)
(2,4)

The deduplication is handled by storing the resulting lists as hash keys. In order to use array references as hash keys we need to use Hash::MultiKey. The target sum and coin value list are set in the Prolog code via string substitution. Of course these could have been set as parameters and passed in the normal way but this seemed slightly more fun!

Artificial Recognition

Let's refer to most all of the current uses of Neural Networks as Artificial Recognition.

The present wave of enthusiasm for Artificial Intelligence has been due to the impressive success of Artificial Neural Networks. We are in the midst of a Cambrian Explosion of Deep Learning techniques which offer a demonstrably powerful solutions to an impressive range of problems: self-driving cars, product recommendations, image recognition, clinical diagnostic, and on and on.

Should we really be calling this intelligence though? For nearly 80 years what we call Artificial Intelligence has changed and undergone categorical revisions. We know have ideas such as Strong AI, Weak AI, Semantic AI, Symbolic AI, Statistical AI, and so on. There is, naturally, overlap in the things these terms refer to. For example, if I use a modern framework such as Google's Tensorflow to do a binary classification of images into two classes "contains stop sign" and "down not contain stop sign" we are using statistical methods to perform a Weak AI task. 

Collapse )