#!/usr/sbin/perl # switchback.pl: Program to determine whether a given word is a "switchback." # # Version 1.0, copyright 1997 by Jed Hartman. # Last modification: 10 July 1997. # # Permission to use, copy, modify, and distribute this software and its # documentation, in whole or in part, for any purpose and without fee is # hereby granted, provided that: (a) the above copyright notice appear in # all copies; (b) both the copyright notice and this permission notice # appear in supporting documentation; and (c) no fee is charged for further # redistribution of the software. This software is provided "as is" without # express or implied warranty. # # Thanks to Jef Poskanzer for the permission-to-use notice. # # # Notes: # # Takes a word as input. Creates a list of all strings which consist of reversing # the given word and changing exactly one letter (to another letter). Then checks # every string in the created list against a given file containing a list of valid # words. The result is a list of all all words (in the given word file) which can be # obtained by spelling the original word backward *and* changing exactly one letter. # # If you have comments or suggestions, write to me at logos@kith.org. I'm a # novice perl hacker and would be delighted to receive style comments. $alphabet = "abcdefghijklmnopqrstuvwxyz"; $wordfilename = "/usr/dict/words"; # Some UNIX systems use "/usr/share/dict/words" instead. $stop = 0; while ($stop == 0) { $wordcount = 0; @foundwords = (); @wordlist = (); print "Enter the word to check, or xxx to stop: "; $word = <>; chop($word); if ($word eq "xxx") { $stop = 1; print "\nGoodbye.\n"; last; } $rev = reverse($word); $rev =~ tr/A-Z/a-z/; $wordlength = length($rev); for ($cur_let_index = 0; $cur_let_index < $wordlength; $cur_let_index++) { $cur_let = substr($rev, $cur_let_index, 1); for ($i = 0; $i < 26; $i++) { $new_let = substr($alphabet, $i, 1); if ($cur_let eq $new_let) { next; } substr($rev, $cur_let_index, 1) = $new_let; $wordcount++; $wordlist[$wordcount] = $rev; substr($rev, $cur_let_index, 1)= $cur_let; } } # Now @wordlist contains a list of 25 * length($word) words, each a reversal- # with-one-letter-changed from $word. So go through each line of the dictionary # file and compare with each of those words... @foundwords = (do lookup(@wordlist)); foreach $word (@foundwords) { print "$word\n"; } } # The 'lookup' function takes a list of word candidates and returns a list of # those candidates which are found in the given word file. # # Assumption is that the word-list file contains one word per line, each line # (including final line) terminated by a return. Words need not be in any # particular order, though if we assume alphabetical, routine could be smarter. # # There's probably a nicer way to do this in Perl, but I didn't see it offhand. sub lookup { @found = (); $foundwordcount = 0; @words = @_; # passed parameter list open(WORDFILE, "$wordfilename"); while ($nextword = ) # get the next line from the word file { chop ($nextword); foreach $to_find (@words) # iterate over all candidate words { if ($to_find eq $nextword) { $found[$foundwordcount++] = $nextword; # add to list of actual words } } } close(WORDFILE); return @found; }