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

[Mark Senn]

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.

# Read names.
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;

# 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 = ();
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