# [Purdue-pm] improved 2015-08-12 challenge problem solution

Mark Senn mark at purdue.edu
Sun Aug 9 04:48:22 PDT 2015

```

PROBLEM DEFINITION

SHORTEN NAMES CHALLENGE PROBLEM
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 "in the bag") I changed this program to
# be similar to the Perl 6 program.

my @name = <DATA>;

# Get first names.
my @first = grep {s/\s.*\n//} @name;

# Save the original first names in %first.
my %first = ();
foreach my \$first (@first)
{
(\$first{\$first})  and  do  {  print "duplicate(s)\n";  exit 1;  };
\$first{\$first} = 1;
}

# Compute all prefixes of @first.
my @prefix = ();
foreach my \$first (@first)
{
for my \$length (1 .. (length \$first) - 1)
{
push @prefix, substr \$first, 0, \$length;
}
}

# Save all prefixes and number of times they exist.
my %prefix = ();
map {\$prefix{\$_}++} @prefix;

# Compute results.
my @result = @first;
foreach my \$candidate (keys %prefix)
{
# Don't save candidates that are the same as existing first names.
(\$first{\$candidate})  and  next;
# Don't save candidates that are not unique.
(\$prefix{\$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;

# 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 = ();
for @first -> \$first
{
(%first{\$first})  and  do  {  say "duplicate(s)";  exit 1;  };
%first{\$first} = 1;
}

# Compute all prefixes of @first.
my @prefix = ();
for @first -> \$first
{
for 1 .. \$first.chars - 1 -> \$length
{
push @prefix, substr \$first, 0, \$length;
}
}

# Save all prefixes and number of times they exist.
my \$prefix = bag @prefix;

# Compute results.
my @result = @first;
for \$prefix.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.
(\$prefix{\$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
```