# [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.

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;

# 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
```