http://www.perlmonks.org?node_id=41175

   1: #!/usr/bin/perl -w
   2: 
   3: # Feel need to prove someone's satan's pawn?
   4: # This script mutilates given name to make the
   5: # sum of ASCII codes 666 (or any number for that).
   6: # Currently quite limited in mutilation strength, I ran
   7: # out of interest.
   8: 
   9: $debug=0;
  10: 
  11: @number=(666);
  12: $verbose=1;
  13: $quitfirst=0;
  14: $viewnumber=0;
  15: $factual=0;
  16: $listnumber=0;
  17: 
  18: while (@ARGV) {
  19:         $t = shift(@ARGV);
  20: 
  21:         if ($t eq "-help") {
  22:                 print<<END_OF_HELP
  23: Usage: satanizer.pl [parameters] <name>
  24: 
  25: "Here is the wisdom. Let him that hath understanding count the number of
  26:       the beast; for it is the number of a man; and his number is
  27:                   Six hundred threescore and six"
  28: 
  29: This program will help you in easily identifying the people who carry
  30: Shai'tan, the Prince of Lies, in their heart through the number of 666.
  31: Just supply the name of person to be examined on the command line and
  32: program will report his true loyalties.
  33: 
  34: Parameters:
  35: 
  36:   -number NUM[,NUM...]     Use alternative number(s) instead of 666. You
  37:                            may also supply multiple numbers, in which
  38:                            case all of them will be checked.
  39:   -silent                  Output only matching names, name-per-line, no
  40:                            useless babble included.
  41:   -stop                    In case of multiple numbers, stop after first
  42:                            matching number.
  43:   -list-number             Under -silent, append the number that matched
  44:                            after the name in output.
  45:   -view-number             Report which number the person would match to
  46:                            without mutilation.
  47:   -proper                  Speak sensibly.
  48:   -file FILE               Get the names to be used from FILE, name per
  49:                            line. Further names on command line will be
  50:                            ignored.
  51:                            
  52: DISCLAIMER: If you are offended by this program, I laugh at you. Please
  53: send emails condemning me to hell for blashpemy to kaatunut\@iki.fi, I
  54: will enjoy them.
  55: 
  56: Send bug reports to kaatunut\@iki.fi.
  57: END_OF_HELP
  58: ;
  59:                 exit;
  60:         } elsif ($t eq "-version") {
  61:                 print<<END_OF_TEXT
  62: Satanize 0.1
  63: 
  64: (c) 2000, Juhan Aslak Näkkäläjärvi
  65: 
  66: This program is free software, and is under the GPL license.
  67: END_OF_TEXT
  68:         } elsif ($t eq "-number") {
  69:                 @number=split /,/,shift(@ARGV);
  70:         } elsif ($t eq "-silent") {
  71:                 $verbose=0;
  72:         } elsif ($t eq "-stop") {
  73:                 $quitfirst=1;
  74:         } elsif ($t eq "-list-number") {
  75:                 $listnumber=1;
  76:         } elsif ($t eq "-view-number") {
  77:                 $viewnumber=1;
  78:         } elsif ($t eq "-proper") {
  79:                 $factual=1;
  80:         } elsif ($t eq "-file") {
  81:                 $filename=shift(@ARGV);
  82:                 open(FILE,$filename) or die "can't open $filename!";
  83:                 push @name,$_ while (<FILE>);
  84:                 close(FILE);
  85:                 chomp @name;
  86:         } elsif (substr($t,0,1) eq "-") {
  87:                 print "Unknown parameter \'$t\'.\n";
  88:         } elsif (!@name) {
  89:                 $name[0]=$t;
  90:                 while (@ARGV) {
  91:                         $name[0].=" ".shift(@ARGV);
  92:                 }
  93:         }
  94: }
  95: if (!defined $listnumber) {
  96:         if (!$verbose && !$quitfirst) {
  97:                 $listnumber=0;
  98:         } else {
  99:                 $listnumber=1;
 100:         }
 101: }
 102: 
 103: if (!@name) {
 104:         print "You need to supply a name.\n";
 105:         exit;
 106: }
 107: 
 108: for $j (0 .. $#name) {
 109:         for $i (0 .. $#number) {
 110:                 my $t;
 111: 
 112:                 $ret=satanize($name[$j],$number[$i],\$mutilation,\$t,0);
 113: 
 114:                 if ($viewnumber) {
 115:                         print "$name[$j]\'s number is $t\n";
 116:                         $viewnumber=0;
 117:                 }
 118: 
 119:                 if (!$ret) {
 120:                         if (satanize($mutilation,$number[$i],0,\$t,1),$t!=$number[$i]) {
 121:                                 die "satanization failure";
 122:                         }
 123:                         if ($verbose) {
 124:                                 if ($factual) {
 125:                                         print "$mutilation matches to $number[$i].\n";
 126:                                 } elsif ($number[$i]==666) {
 127:                                         print "$mutilation is the Satan's incarnate on earth!\n";
 128:                                 } else {
 129:                                         print "$mutilation was born to the number $number[$i].\n";
 130:                                 }
 131:                         } else {
 132:                                 print "$mutilation";
 133:                                 print " - $number[$i]" if $listnumber;
 134:                                 print "\n";
 135:                         }
 136:                         last if $quitfirst;
 137:                 } elsif ($verbose) {
 138:                         if ($ret==1) {
 139:                                 if ($factual) {
 140:                                         print
 141: "$name[$j] cannot be made to have asciisum of $number[$i] by any currently ".
 142: "used mutilation methods. Try changing non-trivial spelling (ie. letters).\n";
 143:                                 } elsif ($number[$i]==666) {
 144:                                         print
 145: "$name[$j]\'s waveform seems to indicate that it is a human. It might be a ".
 146: "guise though, try changing some letters in the name.\n";
 147:                                 } else {
 148:                                         print
 149: "$name[$j]\'s waveform does not match to number $number[$i].\n";
 150:                                 }
 151:                         } elsif ($ret==2) {
 152:                                 if ($factual) {
 153:                                         print
 154: "$name[$j] has too few non-whitespaces to reach $number[$i]. Try adding some.\n";
 155:                                 } elsif ($number[$i]==666) {
 156:                                         print
 157: "$name[$j] has some satanic breed but it lacks strength.\n";
 158:                                 } else {
 159:                                         print
 160: "$name[$j] has shown potential tendencies towards number $number[$i], but it ".
 161: "has no power to reach that.\n";
 162:                                 }
 163:                         } elsif ($ret==3) {
 164:                                 if ($factual) {
 165:                                         print
 166: "$name[$j] has too many non-whitespaces to reach $number[$i]. Try removing some.\n";
 167:                                 } elsif ($number[$i]==666) {
 168:                                         print
 169: "$name[$j] has some satanic breed but it cannot contain its powers.\n";
 170:                                 } else {
 171:                                         print
 172: "$name[$j] has shown potential tendencies towards number $number[$i], but it ".
 173: "cannot contain its powers.\n";
 174:                                 }
 175:                         } else {
 176:                                 print "ACK! $name[$j] must be Satan Himself, you shouldn't ".
 177: "see this message ever :(\n";
 178:                         }
 179:                 }
 180:         }
 181: }
 182: ## satanize(name,number,outname,outnumber,short)
 183: sub satanize {
 184:         my($name,$number)=@_;
 185:         my $num=0;
 186:         my $times=0;
 187:         my $lcase_num=0,$ucase_num=0,$space_num=0;
 188:         my($c,$i,@upl,@downl,@spacel);
 189: 
 190:         for $i (0 .. (length $name)-1) {
 191:                 $c=substr($name,$i,1);
 192:                 $num+=ord $c;
 193:                 if ($c eq " ") {
 194:                         $space_num++;
 195:                         push @spacel,$i;
 196:                 } elsif ($c ne uc $c) {
 197:                         $lcase_num++;
 198:                         push @downl,$i;
 199:                 } elsif ($c ne lc $c) {
 200:                         $ucase_num++;
 201:                         push @upl,$i;
 202:                 }
 203:         }
 204: 
 205:         ${$_[3]}=$num if $viewnumber || $_[4];
 206:         return $num if $_[4];
 207: 
 208:         if ($num==$number) {
 209:                 ${$_[2]}=$name;
 210:                 return 0;
 211:         }
 212: 
 213:         if ((abs($number-$num) % abs(ord('a')-ord('A')))) {
 214:                 print "nondivisible\n" if $debug;
 215:                 return 1;       # not divisible
 216:         }
 217:         $times=($number-$num)/abs(ord('a')-ord('A'));
 218:         if (($times<0 && (-$times)>($lcase_num+$space_num)) ||
 219:                 ($times>0 && $times>$ucase_num)) {
 220:                 print "not enough space: $times transformations needed\n" if $debug;
 221:                 return 2 if $times>0;
 222:                 return 3 if $times<0;
 223:         }
 224: # capitalizing rule: find existing capitalized points and start adding to them
 225: # decapitalizing rule: drop capitalized letters randomly
 226: # spacing rule: remove random spaces after everything is capitalized
 227:         ${$_[2]}=$name;
 228:         if ($times<0) { # Capitalize
 229:                 my $p=0;
 230:                 if (!@upl || $upl[0]!=0) {
 231:                         splice @upl,0,0,-1;
 232:                 }
 233:                 print "capitalize $times times\n" if $debug;
 234:                 while ($times && @upl) {
 235:                         do {
 236:                                 $upl[$p]++;
 237:                                 if ($upl[$p]>=(length ${$_[2]})
 238:                                         || (substr(${$_[2]},$upl[$p],1)
 239:                                                 ne lc substr(${$_[2]},$upl[$p],1))) {
 240: # kill this pointer (and move to next in row):
 241: # at the end of string or at ucase character
 242:                                         print "kill pointer $p at $upl[$p]\n" if $debug;
 243:                                         splice @upl,$p,1;
 244:                                         if (@upl) {
 245:                                                 $p=0 if $p > $#upl;
 246:                                                 redo;
 247:                                         } else {
 248:                                                 print "break\n" if $debug;
 249:                                                 last;
 250:                                         }
 251:                                 } elsif (substr(${$_[2]},$upl[$p],1)
 252:                                                 eq uc substr(${$_[2]},$upl[$p],1)) {
 253: # ignore: uppercase or special character-
 254: # but uppercase was checked above so spec char
 255:                                         redo;
 256:                                 }
 257:                         } while (0);
 258:                         last if not @upl;
 259:                         substr(${$_[2]},$upl[$p],1)=uc substr(${$_[2]},$upl[$p],1);
 260:                         print "  =>${$_[2]}\n" if $debug;
 261:                         $p++;
 262:                         $p=0 if $p>=@upl;
 263:                         print "p now: $p\n" if $debug;
 264:                         $times++;
 265:                 }
 266:                 if ($times) {   # time to remove some spaces!
 267:                         my @kill_list;
 268:                         while ($times) {
 269:                                 $p=int rand @spacel;
 270:                                 push @kill_list,$spacel[$p];
 271:                                 splice @spacel,$p,1;
 272:                                 $times++;
 273:                         }
 274:                         @kill_list=reverse sort @kill_list;
 275:                         print "kill ".@kill_list." spaces\n" if $debug;
 276:                         for $i (0 .. $#kill_list) {
 277:                                 substr(${$_[2]},$kill_list[$i],1)="";
 278:                         }
 279:                 }
 280:                 return 0;
 281:         } else {
 282:                 my $p;
 283:                 print "decapitalize $times times\n" if $debug;
 284:                 while ($times) {
 285:                         $p=int rand @upl;
 286:                         substr(${$_[2]},$upl[$p],1)=lc substr(${$_[2]},$upl[$p],1);
 287:                         splice @upl,$p,1;
 288:                         $times--;
 289:                 }
 290:                 return 0;
 291:         }
 292:         print "bug- shouldn't be here\n";
 293:         return 100;
 294: }