# Here's the updated code to fix the bug where it would erroneously
# remove a substring that appeared in one word twice, but in no other
# word:
# 
#!/usr/bin/perl

use strict;

use Carp;
use IO::File;

# ----------------------------------------------------------------
# Library routines borrowed for this app.

#--->     $it = iterator {code}
#
# Create an iterator object.  From EJR's library.
# 12/28/2001  EJR  First version
sub iterator (&)
{
    return $_[0];
}

#--->     $it = ilist (@list);
#
# Create an iterator to return the items of a list.
# From EJR's library.
# 11/12/2001  EJR  First version
sub ilist
{
    my @items = @_;
    my $index=0;
    return iterator
    {
        return $items[$index++];
    }
}

#--->     $it = ifile ($filename, [$chomp], [$sep]);
#
# Create an iterator to return the lines of a file.  From EJR's library.
# 05/30/2002  EJR  First version
# 06/13/2002  EJR  Added autochomping
sub ifile
{
    my $file = shift;
    my $autochomp = shift;
    if (defined $autochomp)
    {
        croak "Invalid 'chomp' argument to ifile"
            if ($autochomp ne 'chomp' && $autochomp ne 'nochomp');
        $autochomp = $autochomp eq 'chomp';
    }
    else
    {
        $autochomp = 0;    # default
    }

    my $sep  = @_ ? shift : $/;
    my $fh = new IO::File ($file);
    return unless $fh;    # error! caller should check $!.

    return iterator
    {
        # Past EOF already?
        return unless $fh;

        # Argument?
        if (@_)
        {
            my $arg = shift;
            croak "Too many arguments to ifile iterator" if @_;
            croak "Invalid argument to ifile iterator" unless $arg =~ /^(no)?chomp/;
            $autochomp = $1 ne 'no';
            return;
        }

        # Get next line (delimited by $sep);
        my $irs = IO::Handle->input_record_separator($sep);
        my $line = <$fh>;
        chomp $line if defined $line  &&  $autochomp;
        IO::Handle->input_record_separator($irs);

        # Done?
        $fh->close, $fh=undef  if !defined $line;

        # Return the line
        return $line;
    };
}

# ----------------------------------------------------------------
# Subroutines specific to QOTW-8

# $iter = substrings $word, $length;
# Return an iterator to generate all the substrings
# of a given length in a given word.
sub substrings
	{
	my $str = shift;
	my $len = shift;
	my $s = length($str) - $len;

	return iterator
		{
		return if $s < 0;
		return substr $str, $s--, $len;
		}
	}


# $hashref = unique_segments $source, $length;
#
# Find all the unique substrings of length $length in a list
# of words.
#
# Input:
#     $source  - An iterator to return the words, one at a time.
#     $length  - The length of substrings to examine.
# Returns:
#     $hashref - A reference to a hash, mapping word segment -> word.
sub unique_segments
	{
	my $input  = shift;
	my $len    = shift;

	my %words;    # Mapping of substring -> full word
	my %count;    # Number of times each substring has occurred

	my $word;     # loop variable -- current word being processed
	while (defined ($word = $input->()))
		{
		my $chunks = substrings $word, $len;
		while (my $ch = $chunks->())
			{
			next if $words{$ch} eq $word;
			delete $words{$ch}, next if $count{$ch}++;  # delete if it's there
			$words{$ch} = $word;    # add it if it's not
			}
		}

	return \%words;
	}

# simple output function
sub two_columns
	{
	printf "%-23s %s\n", @_;
	}

# ----------------------------------------------------------------
# Main program begins here.

my $input_file_name  = shift || 'wordlist';
my $substring_length = shift || 4;
my $process_function = \&two_columns;

# Generate list and print.
my $w = ifile $input_file_name, 'chomp';
die "Cannot read $input_file_name: $!\n" unless $w;
my $h = unique_segments $w, $substring_length;
$process_function->("'questions'", "'answers'");
$process_function->( $_,            $h->{$_}) for sort keys %$h;

__END__

-- 
Eric J. Roode                                              eric@myxa.com
Senior Software Engineer, Myxa Corporation
tr j, j ,j for @japh = (qw b lre h, uJ p, ekca tona, ts reh b, $/.r);
print scalar reverse sort @japh;
