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: }

Replies are listed 'Best First'.
(brainpan) RE: Satanizer
by brainpan (Monk) on Nov 12, 2000 at 15:09 UTC
    Finally! This code fills an enormous void in my life!

    I find it strange that even the ever vigilant Micros~1 hasn't put forth a product to compete in this field.

    And no, I don't own 27 pairs of sweatpants.
Re: Satanizer
by radagast (Sexton) on Dec 01, 2000 at 14:07 UTC
    Ever consider using Latin or Hebrew, as they were the languages of the time? Here's my favorite, with Barney the purple monstrosity. Take the Latin letters in CUTE PURPLE DINOSAUR, keeping in mind the Romans treated 'U' as 'V'.

    C + V + V + L + D + I + V = 100 + 5 + 5 + 50 + 500 + 1 + 5 = 666

    If you go the Hebrew route, try the kaballah, the mystical side of judaism where all letters have numbers. It could be fun parsing all the names of people around the world until you get a 666. heh heh...

      Here and here are some nice link for such a project :)

      <JOKE>
      And because the American President election isn't over yet, i'll throw in this and this and this links as a bonus... Seems that no matter what the outcome is, it spells 666.
      </JOKE>

      /brother t0mas