#! /usr/bin/perl

# Introduction to PERL using the Sunday Puzzle
# Brad Burkman
#	Louisiana School for Math, Science, and the Arts
#	bburkman@lsmsa.edu

# Curriculum module for the LA-SiGMA RET collection

# This is the challenge from National Public Radio Sunday Puzzle. 
# http://www.npr.org/2013/06/16/191840752/youd-better-sit-tight-for-this-one

# Write down these five words: 
# "mate," "peck," "miss," "pot" and "blunder." 
# There is something very unusual they have in common. 
# What is it? 
# And, can you name one other word with the same property?

# Creighton Eddington found the solution:

# Look at the vowels:  a, e, i, o, and u.
# In each of those words, you can replace the first vowel
# with each of the other four and get a common English word.

# mate, mete, mite, mote, mute ...

# This program is about the second part, 
# "can you name another word with this property?"

# We're going to find all common English words with that property, 
# and we'll throw in 'y' just to be thorough.  

# Why?  Because we can.

# This problem is analogous to:
# You have a genetic sequence.
# Replace the Adenine with each of Cytosine, Guanine, or Thymine.  
# Do you get a known genetic sequence?

# Here's a program written in PERL that finds all possible answers.  

# The real purpose of this exercise is to introduce you to PERL

# Any PERL programmer reading my code will instantly see that 
# I'm a C programmer, not a PERL programmer.
# PERL has lots of neat tricks that I don't know about, 
# and I'm sure the code can be rewritten in ten lines 
# that only the author would understand. 
# When you meet those people, roll your eyes and pity their lack of real lives.

# Here are other Sunday Puzzles susceptible to the same method.  
# Adapt the code to solve these.  

# http://www.npr.org/2013/03/31/175798245/hiding-in-plain-sight
# http://www.npr.org/2013/04/14/177168356/o-say-can-you-c-the-answer
# How many words can you make from the letters in `Shakespeare'?

# The file "wordsEn.txt" comes from the website of SIL, 
# 	formerly called the Summer Institute of Linguistics

# Open the file "wordsEn.txt" for reading.  
# Open the file "Results.txt" for writing.

open ( INPUT, "<wordsEn.txt" );
open ( WRITE, ">AEIOU.txt" );

# Create an array, called "words," 
# and put all of the words in "wordsEn.txt" into it.  

@words = <INPUT>;

# Create an array, "answer," that will temporarily hold the results. 
# If it gets one each of a, e, i, o, and u, then it will write the results.  
# If not, it gets overwritten.

@answer;

# A variable to count the number of results.  
$n=0;

# For each word in the list...
	# The variable $_ is the next element of the array. 
	# Give it a more permanent name, $a.
foreach ( @words ) {
	$a = $_;

	# Go through letter of $a to see if it contains an 'a.'
	for ( $j=0; $j<length($a); $j++ ) {
		# substr ( $a, $j, 1 ) gives the substring from $a, starting at position $j, of length 1.
		if ( substr ( $a, $j, 1 ) eq 'a' ) {
			# Redefine @answer to contain only the element $a.
			@answer = ($a);
			# Search each of the words in the list to see if they are the same as $a, except for one vowel.
			foreach ( @words ) {
				$b = $_;
				if ( 
					# If they have the same length, 
						# the part of the words before the vowel is the same, 
						# the part of the words after the vowel is the same,
						# the words are different, and
						# the remaining letter is e, i, o, or u...
					length($b) == length($a) &&
					substr ( $a, 0, $j ) eq substr ( $b, 0, $j ) &&
					substr ( $a, $j+1, length($a)-($j+1) ) eq substr ( $b, $j+1, length($a)-($j+1) ) &&
					$a ne $b &&
					(
						substr ( $b, $j, 1) eq 'e' ||
						substr ( $b, $j, 1) eq 'i' ||
						substr ( $b, $j, 1) eq 'o' ||
						substr ( $b, $j, 1) eq 'u' 
					)
				) {
					# ...put that word at the end of the array @answer.  
					push ( @answer, $b );
					# If there are five words in @answer, then write it out and start over. 
					if ( scalar(@answer)==5 ) {	
						$n++;
						for ( $i=0; $i<5; $i++ ) {
							$b = $answer[$i];
							chomp $b;
							print WRITE $b, " ";
						}
						print WRITE "\n";
						print @answer, "\n";
					}
				}
			}
		}
	}
}

close INPUT;
close WRITE;


