patternword.pl

• package main
  • patternword
• EOF

   1 #! perl
   2 
   3 require v5.10.0;
   4 use strict;
   5 
   6 our %Tests;
   7 BEGIN{ # initialize early so Test More can see count
   8  %Tests = (
   9 	"counterfeiters" 	=>"ABCDEFGHFIEFGJ", 
  10 	"environmental"		=>"ABCDEFBGABHIJ",
  11 	"environ-mental"	=>"ABCDEFBGABHIJ",
  12 	);
  13 }
  14 sub patternword;
  15 	
  16 my $debug=0; 
  17 if ($debug){
  18 #	use Test::More tests=> scalar(keys(%Tests));
  19 #	while (my($k,$v)=each(%Tests)){is(patternword($k),$v);}
  20 }
  21 
  22 sub patternword { 
  23 	my $w= shift; # word
  24 	# my $A= split '',$w; # comb in p6
  25 	# my %pos = map {($A[$_] => $_)} 0..$
  26 	warn "<$w\n" if $debug;
  27 	$w =~ tr/a-zA-Z//cd; # alpha only. 
  28 	warn ">$w\n" if $debug;
  29 	# dedup
  30 	my $letters = lc $w; 
  31 	warn ">$letters\n"  if $debug;
  32 	1 while $letters =~ s/(.).*\K\1//g;
  33 	warn ">$letters\n"  if $debug;
  34 	
  35 	 eval " tr/$letters/A-Z/, 1" for $w;
  36 	 die "$@ : tr/$letters/A-Z/" if $@; # exception to eval rule ! 
  37 	warn "=>$w\n"  if $debug;
  38 	 return $w;
  39 	}
  40 
  41 my (	$duckword, $n);
  42 
  43 if ('--find' eq $ARGV[0])
  44 {
  45 	shift;
  46 	$duckword=patternword(lc shift);
  47 	$n=length($duckword);
  48 	warn "searching for $duckword $n\n";
  49 }
  50 	
  51 	return if $debug;
  52 	
  53 while (<>) {
  54 	chop while /\s$/; # tolerate DOS, UNIX, MAC anywhere
  55 	next if /^\s*#/; # skip comments
  56 	next unless ! defined $n or $n == length;
  57 	my $pw=patternword($_);
  58 	
  59 	print "$.\t$_\n" if defined $duckword and $pw  eq $duckword;
  60 	printf  "%s\t%s\n%s\t%s\n",
  61 		lc $_, $pw, # LC so alphabetizes at plaintext
  62 		   $pw, $_   # leave propernouns uppercase when column 2
  63 		unless defined $duckword; 
  64 } continue {
  65 	close ARGV if eof; # Not eof()!
  66 }