Skip to content

Beautiful Perl

July 16, 2010

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;

    $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 🙂


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.

3 Comments leave one →
  1. July 18, 2010 1:48 am

    In case anyone is curious to see more entries from the 2008 contest, I’ve put all of mine in a github repository: dagolden-scripting-games-2008.

    Other than pragmas, my solution to event 1 was just 5 lines long. Compare that to the Microsoft solution!

    • July 18, 2010 12:06 pm

      I believe I can knock one line off your 5 by removing the num2chars array and generating the regex programatically from the input data

      say "Enter a seven-digit phone number:";
      (my $regex = join(q(), map {($_>1)?'['.chr($_*3+59).chr($_*3+60).chr($_*3+61).']':''} split (//, , 7)))=~tr/Q-X/R-Y/;
      open my $dict, 'C:\Scripts\wordlist.txt' or die $!;
      while ( my $line = uc  ) { say($line), last if $line =~ /^$regex$/ } 
    • July 19, 2010 3:31 pm

      Nice one David.

      To help collate all this stuff for “posterity” I’ve added Microsoft Scripting Games page to the Perl 5 wiki:

      For now its just using the WayBackMachine links for the original Microsoft content.


Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: