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