transfixed but not dead!

Trying to kill two birds with one stone here. There is a new site called UseTheSource where beautiful or interesting code can be posted.

So I thought this might be a good opportunity to get more Modern Perl code across the eyes of the unbelievers

So to start the ball rolling I thought I’d post a link to the code used in the Microsoft Winter Scripting Games 2008, as mentioned by chromatic in his The Opposite of Modern post.

However typically Microsoft they’ve now broken the links. And even worse they seemed to have removed all content related to the Scripting Games from their websites

Tut tut. Luckily the content can be retrieved via WayBackMachine. Here is the article linked in chromatic’s post.

So while the first bird was to bring UseTheSource to everyones attention, the second bird was to make sure the lost code was resurrected from the dead by saving it here.

This was the challenge:

The first event requires the script to request a 7-digit phone number from the user and then select a corresponding phoneword from the “wordlist.txt” file. The letters in the phone number need to be mapped the same way they are represented on a North American phone dial

And below is the code:

use strict;
use warnings;

print "Enter 7 digit phone number: ";
chomp(my $number = <>);
die "Invalid number: '$number'\n" unless $number =~ /^\d{7}$/;

my @groups = qw(ABC DEF GHI JKL MNO PRS TUV WXY);
my($letters, $digits);
foreach my $digit (2..9) {
    my $group = $groups[$digit-2];
    $letters .= $group;
    $digits  .= $digit x length($group);
}

open(my $fh, "<", "C:/Scripts/wordlist.txt") or die;
while (<$fh>) {
    local $_ = $_;
    eval "tr/$letters\L$letters\E/$digits$digits/";
    last if /^$number$/o;
}
print uc if defined;

This is Jan Dubois wonderful idiomatic Perl riposte to (what I believe is) Microsoft’s original stab at a Perl solution:

%dictionary = ();

$dictionary{2} = "ABC";
$dictionary{3} = "DEF";
$dictionary{4} = "GHI";
$dictionary{5} = "JKL";
$dictionary{6} = "MNO";
$dictionary{7} = "PRS";
$dictionary{8} = "TUV";
$dictionary{9} = "WXY";

open (WordList, "C:\\Scripts\\WordList.txt");
@arrWordList = <WordList>;
close (WordList);

$strWordList = join(" ", @arrWordList);

print "Please enter the phone number: ";
$phonenumber = <>;

$low = 0;
$high = 3;

do
{
    $strCharacters = "";

    for ($i = 0; $i < 7; $i++)
        {
            $intValue = substr($phonenumber, $i, 1);
            $letters = $dictionary{$intValue};
            $b = int(rand($high) + $low);
            $substring = substr($letters, $b, 1);
            $strCharacters = $strCharacters . $substring
        }

if ($strWordList =~ m/$strCharacters/i)
    {
        print $strCharacters;
        $x = 1;
    }
}
until $x == 1

Proof that you can really write FORTRAN in any language

This article is now self referentially posted to UseTheSource.

BTW, If you post a link or code to UseTheSource by Monday, July 19 at 0800 BST then you are in with a chance of winning the “Beautiful Code” e-book.

Hopefully that will give you an incentive to waste a bit of time online this weekend

/I3az/

PS. Additionally to this there was another wonderful solution posted by Gav.

PPS. Gav also provided a more idiomatic solution to Game Event 3. The original Microsoft solution can be found here on the WayBackMachine (if you dare look!). I’ve also posted Gav’s solution to this on UseSourceCode.

Don’t recall seeing anyone blog about it and in fact the documentation is pretty sparse but from Perl 5.12 each can now iterate over an array like so:

use 5.012;
use warnings;

my @array = 'a' .. 'h';

while (my ($i, $val) = each @array) {
    say "$i => $val";
}

each on an array returns two values… the index and the value of the current iteration. Thus we get this output from above code:

  0 => a
  1 => b
  2 => c
  3 => d
  4 => e
  5 => f
  6 => g
  7 => h

Anyway to save me thinking up a blog post please excuse me while I just regurgitate my Stackoverflow answer I gave earlier today about using each with an array:

==start==
Starting with Perl 5.12, each is now more flexible by also working on arrays:

use 5.012;
use warnings;

my @tokens = 'a' .. 'z';

while (my ($i, $val) = each @tokens) {
    if ($val =~ m/[aeiou]/) {
        ($i, $val) = each @tokens;   # get next token after a vowel
        print $val;
    }
}

# => bfjpv

One caveat with each, remember the iterator is global and is not reset if you break out of a loop.

For eg:

while (my ($i, $val) = each @tokens) {
    print $val;
    last if $i == 12;
}

# => abcdefghijklm

my ($i, $val) = each @tokens;
say "Now at => $val ($i)";         # Now at => n (13)

So use keys or values to manually reset the iterator:

keys @tokens;                      # resets iterator
($i, $val) = each @tokens;
say "Now at => $val ($i)";         # Now at => a (0)

==end==

I’ve just come back from a nice weeks break… so I’m still a lazy git in holiday mode here

/I3az/