Here’s this past week’s NPR puzzle:

Think of a well-known celebrity who goes by a single name — the last two letters of which are alphabetically separated by only one letter (like A and C, or B and D). Replace this pair of letters with the one that separates them, and you’ll have a common, everyday word. What is it?

It used to be that a puzzle like this was tough to solve with a computer program, because there wasn’t a list of famous names available anywhere. Well, now there is such a list, and it makes solving things like this a snap. You will still need a list of common words to solve this puzzle, but those are available all over. I used the Enable dictionary from the NPL.

A few interesting quirks happened along the way to solving this puzzle. First, it turns out that this particular person isn’t listed in Wikipedia by only his/her first name. So I had to tweak the code a bit to look at all possible first names in my list. This created a bit of a logjam because ROBERT -> ROBES comes up a ton. So the final hacked code to give the answer is below. Not my best work, but not bad for ten minutes.

It’s also a relief to see that the intended answer had a score of 100. YAY FAMOUS PEOPLE LIST

#!/usr/bin/perl -w

use strict;

my $USAGE = "Usage: $0 NAME_FILE WORDLIST_FILE";

my $name_file = $ARGV[0] or die $USAGE;
my $word_list_file = $ARGV[1] or die $USAGE;

my %names;
open FILE1, $name_file or die $!;
while (<FILE1>)
{
	chomp;
	# Everything uppercase for consistency
	my $name = uc $_;
	my $score = 100;
	# Take out names with spaces
	#next if $name =~ / /;
	if ($name =~ /^(.*)\t(\d+)$/) {$name = $1;$score = $2;}
	$names{$name} = $score;
}
close FILE1;

my %words;
open FILE2, $word_list_file or die $!;
while (<FILE2>)
{
	chomp;
	$words{uc $_} = 1;
}
close FILE2;

# Go through names to find a match
my %used;
while (my ($name, $score) = each(%names))
{
	my $first; my $second;
	if ($name =~ /^(.*?) /) {$name = $1;}
	if ($name =~ /^(.*)(..)$/)
	{
		$first = $1;
		$second = $2;
	}
	next unless $second;
	#print "$name $first $second\n";
	my $num = ord(substr($second,0,1));
	if (ord(substr($second,1,1)) == $num + 2)
	{
		my $let = chr($num + 1);
		my $word = $first . $let;
		if ($words{$word} && !$used{$name})
		{
			print "$score\t$name\t$word\n";
			$used{$name} = 1;
		}
	}
}