Re: [FWP] Call for Programs: the "phonecode" benchmark

[Roland Giersig <roland.giersig@alcatel.at>]

OK, a challenge is a challenge, and I'll bite.

Figuring out the algorithm was fun, getting it
to behave exactly as specified was quite mind-boggeling.
It passes the testrun as specified, I hope the testdataset
was complete.

I'm eagerly waiting to see what others come up with.

Roland

--- snip ---
#-*-cperl-*-
#
# phonecode: find character representations for numbers
#
# see URL http://wwwipd.ira.uka.de/~prechelt/phonecode/taskdescription.html
# for complete spec.
#
# Date: Thu Nov 18 15:37:31 MET 1999
#
# Author: Roland Giersig <Roland.Giersig@gmx.at>
#
# Copyright Notice: do with it whatever you want. But if you
# do make money from it, I at least deserve some credits, don't I?

use strict;
require 5;			# just to be sure

my %Dict; # contains word lists indexed by their number representation

sub findsubnr ($);		# predeclare worker sub

my ($Dictfile, $Nrfile) = @ARGV; # input parameters

# open files first so we avoid unnecessary work if something's wrong

open DICT, $Dictfile
  or die "Cannot open dictionary file $Dictfile: $!\n";
open NRS, $Nrfile
  or die "Cannot open numbers file $Nrfile: $!\n";

# first, build some lookup tables

my @Chars = qw(e jnq rwx dsy ft am civ bku lop ghz); # mapping as specified

# create lookup for converting chars to numbers
my $i = -1;
my %Char2Nr = map { $i++;   # increment here to avoid clobbering last result
		    map { (uc $_, $i, # uppercase
			   lc $_, $i) # and lowercase
			}
		      split(//, $_) } @Chars;

# add allowed, but ignored chars per definitionem
$Char2Nr{'"'} = '';
$Char2Nr{'-'} = '';

# slurp in dict
while (defined ($_ = <DICT>)) {
  chomp; s/\s//g;	             # remove whitespace
  my $nr = join ('',		     # rejoin numbers
		 map {$Char2Nr{$_}}  # map to number
		 (split //, $_));    # split word into chars
  push @{$Dict{$nr}}, $_;  # add to list of words that map to that number
}

close DICT;

# read numbers
while (defined ($_ = <NRS>)) {
  chomp;
  my $nr = $_;			# keep original nr around for print-out
  $nr =~ s/[^0-9]//g;		# convert to pure number
  my @s = findsubnr($nr);	# find substrings
  foreach my $w (@s) {
    print "$_: $w\n";
  }
  if (not @s) {			# try first as nr only if we found nothing else
    my $first = substr($nr, 0, 1);
    foreach my $w (findsubnr(substr($nr, 1))) {
      print "$_: $first $w\n";
    }
  }
}

close NRS;

exit 0;

######################################################################
sub findsubnr ($) {
  my ($nr) = @_;
  my @out = ();
  my @s;

  my $i = length($nr) - 1;

  # full match ?
  if (exists $Dict{$nr}) {
    push @out, @{$Dict{$nr}};
  }

  # try with last digit removed
  my $s = substr($nr, 0, $i);
  my $n = substr($nr, $i, 1);
  if (exists $Dict{$s}) {
    push @out, map { "$_ $n" } @{$Dict{$s}};
  }

  # try substrings
  while (--$i > 0) {
    my $s = substr($nr, 0, $i);
    if (exists $Dict{$s}) {
      @s = findsubnr(substr($nr, $i)); # go and find trailing substrings
      foreach my $word (@{$Dict{$s}}) {
	push @out, map { "$word $_" } @s;
      }
      if (not @s) {		# try first as nr only if we found nothing else
	@s = findsubnr(substr($nr, $i+1));
	my $n = substr($nr, $i, 1);
	foreach my $word (@{$Dict{$s}}) {
	  push @out, map { "$word $n $_" } @s;
	}
      }
    }
  }
  return @out;
}

__END__

--
Roland.Giersig@alcatel.at         Phone: +43-1-27722-3755
ALCATEL Austria, Dept. RTPM       FAX:   +43-1-27722-3955
Scheydgasse 41, A-1210 WIEN, Austria (no Kangaroos here!)

==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe