Re: [FWP] name-a-band

[Jeff Pinyan <jeffp@crusoe.net>]

On the topic of /usr/dict/words programs, here's a more-than-interactive
spell checker I wrote over the course of a couple hours one night, for a
friend.

Comments are appreciated.  I've not touched it in quite a while.  I should
check it under -w.

#!/usr/bin/perl

use strict;
$| = 1;

my $clear = `clear`;

my $wordlist = "/home/jeffp/local/lib/pspell/words";
my ($chars,%words,%chars,%append,%ignore);

print "Building word list...\n";
{
	local @ARGV = $wordlist;
	chomp, $words{$_} = 1 while <>;
}
die "$wordlist error: $!\n" unless keys %words;
print "Done.\n\n";

print "Building character list...\n";
while (($_) = each %words){
	if (!$chars || /[^$chars]/){
		@chars{ split // } = ();
		$chars = join "", keys %chars;
	}
}
print "Done.\n\n";

$chars .= "'";
$chars = quotemeta($chars);

for (@ARGV){
	print $clear;
	my ($filename,$ln,%change) = ($_,0);
	open FILE, $filename or warn("can't open $filename: $!") and next;
	while (<FILE>){
		$ln++;
		chomp;

		print "\nFile: $filename\n" if $ln == 1;
		my $line = $_;

		s/[^$chars]+/ /ogi;
		while (/(\S+)/g){
			next if exists $words{lc($1)};
			next if exists $append{lc($1)};
			my ($word,$len) = ($1,length($1));
			my $pos = ($line =~ /\b\Q$word\E\b/g, pos($line));
			my $where = " " x length($line);
			my $c = "";
			substr($where,$pos-$len,$len,("^" x $len));

			printf << "END", $ln, "";
%4d: $line
%4s  $where
END
			print "\t'$word'\n";
			print("[A]ppend, [I]gnore, [G]lobal Ignore, [C]hange? "),
				$c = lc(substr(<STDIN>,0,1)) until $c =~ /[aigc]/;
			$c eq "a" and $append{lc($word)} = 1 and next;
			$c eq "i" and next;
			$c eq "g" and $ignore{lc($word)} = 1 and next;
			$c eq "c" and push @{ $change{$ln} }, [$word,$pos-$len,getrep($word)];
		}
	}
	close FILE;

	if (keys %change){
		local ($^I,$.,@ARGV) = ("", 0, $filename);
		while (<>){
			for my $data (@{ $change{$.} }){
				my ($from,$where,$to) = @$data;
				substr($_,$where,length($from),$to);
			}
			print;
		}
		close ARGV;
	}
}


if (keys %append){
	open WORDS, "+<$wordlist" or die "can't append to $wordlist: $!\n";
	seek WORDS, -1, 2;
	print WORDS map "$_\n", sort keys %append;
	print WORDS "\n";
	close WORDS;
}


sub getrep {
	my $word = shift;
	my ($rep,$c);
	print "\tReplacement for '$word': ";
	chomp($rep = <STDIN>);
	return $rep if exists $words{lc($rep)};

	print "\t'$rep' not found in dictionary.\n";
	print("\t[A]ppend, [I]gnore, [G]lobal Ignore, [C]hange? "),
		$c = lc(substr(<STDIN>,0,1)) until $c =~ /[aigc]/;
	$c eq "a" and $append{lc($rep)} = 1 and return $rep;
	$c eq "i" and return $rep;
	$c eq "g" and $ignore{lc($rep)} = 1 and return $rep;
	$c eq "c" and return getrep($rep);
}


-- 

  MIDN 4/C PINYAN, USNR, NROTCURPI     http://www.pobox.com/~japhy/
  jeff pinyan: japhy@pobox.com     perl stuff: japhy+perl@pobox.com
  "The Art of Perl"               http://www.pobox.com/~japhy/book/      
  CPAN ID: PINYAN  http://www.perl.com/CPAN/authors/id/P/PI/PINYAN/
  PerlMonth - An Online Perl Magazine     http://www.perlmonth.com/


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