[Purdue-pm] my 2015-08-12 challenge problem solution
Mark Senn
mark at purdue.edu
Sat Aug 8 20:58:14 PDT 2015
PROBLEM DEFINITION
SHORTEN NAMES CHALLENGE PROBLEM
last improved on 2015-08-08
Write Perl 5 and Perl 6 programs to do the following. You are not
allowed to use any additional Perl modules. You must only use the
built-in features in Perl 5 or Perl 6. Hint: Perl 6 has sets, bags, and
mixes, see
http://doc.perl6.org/language/setbagmix
Read the names from a Perl data section one name per line. Do error
checking to make sure you aren't given duplicate first names. If there
is a duplicate first name print a "duplicate(s)" line and exit.
Given a list of names, shorted the first names as much as possible
so they still refer unambigously to a single person.
For example,
THESE NAMES CAN BE SHORTENED TO
----------- -------------------
Abe Lincoln Ab Abe
Alan Turing Al Ala Alan
Ben Carson B Be Ben
Cat Stevens Cat
Cathy Rigby Cath Cathy
Abe can't be shorted to A because we'd get Abe Lincoln and Alan Turing
confused. Cath is not shortened to Cat because we'd get Cat Stevens
and Cathy Rigby confused. The program's output should be the
shortened names in sorted order like this:
Ab
Abe
Al
Ala
Alan
B
Be
Ben
Cat
Cath
Cathy
-mark
COMMENT
Human time costs more than computer time. I didn't bother to
optimize the Perl 5 or Perl 6 solutions.
PERL 5 SOLUTION
#!/usr/local/bin/perl
use warnings;
use strict;
# Originally I had an overly complex solution. After I did a Perl 6
# solution that used bags (keys are what's in the bag, values are how
# many copies of that key are considered "in the bag") I changed this
# program to be similar to the Perl 6 program.
# Read names.
my @name = <DATA>;
# Get first names.
my @first = grep {s/\s.*\n//} @name;
# Save the original first names in %first.
my %first = ();
map {$first{$_} = 1} @first;
# Compute all prefixes of @first.
my @all = ();
foreach my $first (@first)
{
for my $length (1 .. (length $first) - 1)
{
push @all, substr($first,0,$length);
}
}
# Make a hash with keys @all and values that are the count of how many
# of @all have this key.
my %count = ();
map {$count{$_}++} @all;
# Compute results.
my @result = @first;
foreach my $candidate (keys %count)
{
# Don't save candidates that are the same as existing first names.
($first{$candidate}) and next;
# Don't save candidates that are not unique.
($count{$candidate} > 1) and next;
# If we get here the candidate can be saved as a result.
push @result, $candidate;
}
# Print results.
map {print "$_\n"} sort @result;
__END__
Abe Lincoln
Alan Turing
Ben Carson
Cat Stevens
Cathy Rigby
PERL 6 SOLUTION
#!/usr/new/bin/perl6
# Complain if Perl 5 tries to run this file.
use v6;
# Read names.
# DATA sections aren't implemented in Perl 6 yet.
# I'll use a here document instead.
my @name = q:to/END/.lines;
Abe Lincoln
Alan Turing
Ben Carson
Cat Stevens
Cathy Rigby
END
# Get first names.
my @first = grep {s/\s.*//}, @name;
# Save the original first names in %first.
my %first = ();
map {%first{$_} = 1}, @first;
# Compute all prefixes of @first.
my @all = ();
for @first -> $first
{
for 1 .. $first.chars - 1 -> $length
{
push @all, substr($first,0,$length);
}
}
# Make a bag containing all prefixes.
my $all-bag = bag @all;
# Compute results.
my @result = @first;
for $all-bag.keys -> $candidate
{
# Don't save candidates that are the same as existing first names.
(%first{$candidate}) and next;
# Don't save candidates that are not unique.
($all-bag{$candidate} > 1) and next;
# If we get here the candidate can be saved as a result.
push @result, $candidate;
}
# Print results.
map {say $_}, sort @result;
-mark
More information about the Purdue-pm
mailing list