[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