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.
22 my $term = (lc $message eq 'me') ? $::who : $message;
24 if ($term =~ /^$::mask{chan}$/) {
25 &::status("Doing nickometer for chan $term.");
27 if (!&::validChan($term)) {
28 &::msg($::who, "error: channel is invalid.");
34 foreach (keys %{ $::channels{lc $term}{''} }) {
37 &WARN("nickometer: nick in chan $term undefined?");
41 my $value = &nickometer($str);
42 $nickometer{$value}{$str} = 1;
46 ### TODO: compact with map?
48 foreach (sort {$b <=> $a} keys %nickometer) {
49 my $str = join(", ", sort keys %{ $nickometer{$_} });
50 push(@list, "$str ($_%)");
53 &::performStrictReply( &::formListReply(0, "Nickometer list for $term ", @list) );
59 my $percentage = &nickometer($term);
61 if ($percentage =~ /NaN/) {
62 $percentage = "off the scale";
64 $percentage = sprintf("%0.4f", $percentage);
65 $percentage =~ s/(\.\d+)0+$/$1/;
69 if ($::msgType eq 'public') {
70 &::say("'$term' is $percentage lame, $::who");
72 &::msg($::who, "the 'lame nick-o-meter' reading for $term is $percentage, $::who");
82 # return unless &loadPerlModule("Getopt::Std");
83 return unless &::loadPerlModule("Math::Trig");
86 &::DEBUG("nickometer: arg == NULL. $text");
90 # Deal with special cases (precede with \ to prevent de-k3wlt0k)
104 '[l1](oo?|u)[sz]er' => 500,
115 foreach my $special (keys %special_cost) {
116 my $special_pattern = $special;
117 my $raw = ($special_pattern =~ s/^\\//);
119 unless (defined $raw) {
120 $nick =~ tr/023457+8/ozeasttb/;
122 &punish($special_cost{$special}, "matched special case /$special_pattern/")
123 if (defined $nick and $nick =~ /$special_pattern/i);
126 # Allow Perl referencing
127 $text =~ s/^\\([A-Za-z])/$1/;
129 # C-- ain't so bad either
132 # Punish consecutive non-alphas
133 $text =~ s/([^A-Za-z0-9]{2,})
134 /my $consecutive = length($1);
135 &punish(&slow_pow(10, $consecutive),
136 "$consecutive total consecutive non-alphas")
141 # Remove balanced brackets (and punish a little bit) and punish for unmatched
142 while ($text =~ s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x ||
143 $text =~ s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x ||
144 $text =~ s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
146 print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
147 &punish(15, "brackets");
149 my $parentheses = $text =~ tr/(){}[]/(){}[]/;
150 &punish(&slow_pow(10, $parentheses),
151 "$parentheses unmatched " .
152 ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
156 my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
157 for my $digit (0 .. 9) {
158 my $occurrences = $text =~ s/$digit/$digit/g || 0;
159 &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
161 (($occurrences == 1) ? 'occurrence' : 'occurrences') .
166 # An alpha caps is not lame in middle or at end, provided the first
168 my $orig_case = $text;
169 $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
171 # A caps first alpha is sometimes not lame
172 $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
174 # Punish uppercase to lowercase shifts and vice-versa, modulo
176 my $case_shifts = &case_shifts($orig_case);
177 &punish(&slow_pow(9, $case_shifts),
178 $case_shifts . ' case ' .
179 (($case_shifts == 1) ? 'shift' : 'shifts'))
180 if ($case_shifts > 1 && /[A-Z]/);
182 # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
183 &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
185 # Punish letter to numeric shifts and vice-versa
186 my $number_shifts = &number_shifts($_);
187 &punish(&slow_pow(9, $number_shifts),
188 $number_shifts . ' letter/number ' .
189 (($number_shifts == 1) ? 'shift' : 'shifts'))
190 if $number_shifts > 1;
192 # Punish extraneous caps
193 my $caps = $text =~ tr/A-Z/A-Z/;
194 &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
196 # One and only one trailing underscore is OK.
199 # Now punish anything that's left
201 $remains =~ tr/a-zA-Z0-9//d;
202 my $remains_length = length($remains);
204 &punish(50 * $remains_length + &slow_pow(9, $remains_length),
205 $remains_length . ' extraneous ' .
206 (($remains_length == 1) ? 'symbol' : 'symbols'))
209 print "\nRaw lameness score is $score\n" if $verbose;
211 # Use an appropriate function to map [0, +inf) to [0, 100)
212 my $percentage = 100 *
213 (1 + &Math::Trig::tanh(($score-400)/400)) *
214 (1 - 1/(1+$score/5)) / 2;
216 my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
218 return sprintf "%.${digits}f", $percentage;
221 sub case_shifts ($) {
222 # This is a neat trick suggested by freeside. Thanks freeside!
226 $shifts =~ tr/A-Za-z//cd;
227 $shifts =~ tr/A-Z/U/s;
228 $shifts =~ tr/a-z/l/s;
230 return length($shifts) - 1;
233 sub number_shifts ($) {
236 $shifts =~ tr/A-Za-z0-9//cd;
237 $shifts =~ tr/A-Za-z/l/s;
238 $shifts =~ tr/0-9/n/s;
240 return length($shifts) - 1;
246 return $x ** &slow_exponent($y);
249 sub slow_exponent ($) {
252 return 1.3 * $x * (1 - &Math::Trig::atan($x/6) *2/$pi);
258 return int($float) + ((int($float) == $float) ? 0 : 1);
262 my ($damage, $reason) = @_;
264 return unless $damage;
267 print "$damage lameness points awarded: $reason\n" if $verbose;