2 # Lame-o-Nickometer backend
4 # (c) 1998 Adam Spiers <adam.spiers@new.ox.ac.uk>
6 # You may do whatever you want with this code, but give me credit.
18 # return unless &loadPerlModule("Getopt::Std");
19 return unless &loadPerlModule("Math::Trig");
25 &DEBUG("nickometer: arg == NULL.");
29 # Deal with special cases (precede with \ to prevent de-k3wlt0k)
43 '[l1](oo?|u)[sz]er' => 500,
54 foreach my $special (keys %special_cost) {
55 my $special_pattern = $special;
56 my $raw = ($special_pattern =~ s/^\\//);
58 unless (defined $raw) {
59 $nick =~ tr/023457+8/ozeasttb/;
61 &punish($special_cost{$special}, "matched special case /$special_pattern/")
62 if (defined $nick and $nick =~ /$special_pattern/i);
65 # Allow Perl referencing
68 # C-- ain't so bad either
71 # Punish consecutive non-alphas
73 /my $consecutive = length($1);
74 &punish(&slow_pow(10, $consecutive),
75 "$consecutive total consecutive non-alphas")
80 # Remove balanced brackets and punish for unmatched
81 while (s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x ||
82 s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x ||
83 s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
85 print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
87 my $parentheses = tr/(){}[]/(){}[]/;
88 &punish(&slow_pow(10, $parentheses),
89 "$parentheses unmatched " .
90 ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
94 my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
95 for my $digit (0 .. 9) {
96 my $occurrences = s/$digit/$digit/g || 0;
97 &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
99 (($occurrences == 1) ? 'occurrence' : 'occurrences') .
104 # An alpha caps is not lame in middle or at end, provided the first
107 s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
109 # A caps first alpha is sometimes not lame
110 s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
112 # Punish uppercase to lowercase shifts and vice-versa, modulo
114 my $case_shifts = &case_shifts($orig_case);
115 &punish(&slow_pow(9, $case_shifts),
116 $case_shifts . ' case ' .
117 (($case_shifts == 1) ? 'shift' : 'shifts'))
118 if ($case_shifts > 1 && /[A-Z]/);
120 # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
121 &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
123 # Punish letter to numeric shifts and vice-versa
124 my $number_shifts = &number_shifts($_);
125 &punish(&slow_pow(9, $number_shifts),
126 $number_shifts . ' letter/number ' .
127 (($number_shifts == 1) ? 'shift' : 'shifts'))
128 if $number_shifts > 1;
130 # Punish extraneous caps
131 my $caps = tr/A-Z/A-Z/;
132 &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
134 # Now punish anything that's left
136 $remains =~ tr/a-zA-Z0-9//d;
137 my $remains_length = length($remains);
139 &punish(50 * $remains_length + &slow_pow(9, $remains_length),
140 $remains_length . ' extraneous ' .
141 (($remains_length == 1) ? 'symbol' : 'symbols'))
144 print "\nRaw lameness score is $score\n" if $verbose;
146 # Use an appropriate function to map [0, +inf) to [0, 100)
147 my $percentage = 100 *
148 (1 + tanh(($score-400)/400)) *
149 (1 - 1/(1+$score/5)) / 2;
151 my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
153 return sprintf "%.${digits}f", $percentage;
156 sub case_shifts ($) {
157 # This is a neat trick suggested by freeside. Thanks freeside!
161 $shifts =~ tr/A-Za-z//cd;
162 $shifts =~ tr/A-Z/U/s;
163 $shifts =~ tr/a-z/l/s;
165 return length($shifts) - 1;
168 sub number_shifts ($) {
171 $shifts =~ tr/A-Za-z0-9//cd;
172 $shifts =~ tr/A-Za-z/l/s;
173 $shifts =~ tr/0-9/n/s;
175 return length($shifts) - 1;
181 return $x ** &slow_exponent($y);
184 sub slow_exponent ($) {
187 return 1.3 * $x * (1 - atan($x/6) *2/$pi);
193 return int($float) + ((int($float) == $float) ? 0 : 1);
197 my ($damage, $reason) = @_;
199 return unless $damage;
202 print "$damage lameness points awarded: $reason\n" if $verbose;