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 }{''} } ) {
36 if ( !defined $str ) {
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(
54 &::formListReply( 0, "Nickometer list for $term ", @list ) );
59 my $percentage = &nickometer($term);
61 if ( $percentage =~ /NaN/ ) {
62 $percentage = 'off the scale';
65 $percentage = sprintf( "%0.4f", $percentage );
66 $percentage =~ s/(\.\d+)0+$/$1/;
70 if ( $::msgType eq 'public' ) {
71 &::say("'$term' is $percentage lame, $::who");
75 "the 'lame nick-o-meter' reading for $term is $percentage, $::who"
86 # return unless &loadPerlModule("Getopt::Std");
87 return unless &::loadPerlModule("Math::Trig");
89 if ( !defined $text ) {
90 &::DEBUG("nickometer: arg == NULL. $text");
94 # Deal with special cases (precede with \ to prevent de-k3wlt0k)
108 '[l1](oo?|u)[sz]er' => 500,
119 foreach my $special ( keys %special_cost ) {
120 my $special_pattern = $special;
121 my $raw = ( $special_pattern =~ s/^\\// );
123 unless ( defined $raw ) {
124 $nick =~ tr/023457+8/ozeasttb/;
126 &punish( $special_cost{$special},
127 "matched special case /$special_pattern/" )
128 if ( defined $nick and $nick =~ /$special_pattern/i );
131 # Allow Perl referencing
132 $text =~ s/^\\([A-Za-z])/$1/;
134 # C-- ain't so bad either
137 # Punish consecutive non-alphas
138 $text =~ s/([^A-Za-z0-9]{2,})
139 /my $consecutive = length($1);
140 &punish(&slow_pow(10, $consecutive),
141 "$consecutive total consecutive non-alphas")
146 # Remove balanced brackets (and punish a little bit) and punish for unmatched
147 while ($text =~ s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x
148 || $text =~ s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x
149 || $text =~ s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x )
151 print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
152 &punish( 15, 'brackets' );
154 my $parentheses = $text =~ tr/(){}[]/(){}[]/;
156 &slow_pow( 10, $parentheses ),
157 "$parentheses unmatched "
158 . ( $parentheses == 1 ? 'parenthesis' : 'parentheses' )
162 my @k3wlt0k_weights = ( 5, 5, 2, 5, 2, 3, 1, 2, 2, 2 );
163 for my $digit ( 0 .. 9 ) {
164 my $occurrences = $text =~ s/$digit/$digit/g || 0;
166 $k3wlt0k_weights[$digit] * $occurrences * 30,
168 . ( ( $occurrences == 1 ) ? 'occurrence' : 'occurrences' )
173 # An alpha caps is not lame in middle or at end, provided the first
175 my $orig_case = $text;
176 $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
178 # A caps first alpha is sometimes not lame
179 $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
181 # Punish uppercase to lowercase shifts and vice-versa, modulo
183 my $case_shifts = &case_shifts($orig_case);
185 &slow_pow( 9, $case_shifts ),
186 $case_shifts . ' case ' . ( ( $case_shifts == 1 ) ? 'shift' : 'shifts' )
187 ) if ( $case_shifts > 1 && /[A-Z]/ );
189 # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
190 &punish( 50, 'last alpha lame' ) if $orig_case =~ /[XZ][^a-zA-Z]*$/;
192 # Punish letter to numeric shifts and vice-versa
193 my $number_shifts = &number_shifts($_);
195 &slow_pow( 9, $number_shifts ),
198 . ( ( $number_shifts == 1 ) ? 'shift' : 'shifts' )
199 ) if $number_shifts > 1;
201 # Punish extraneous caps
202 my $caps = $text =~ tr/A-Z/A-Z/;
203 &punish( &slow_pow( 7, $caps ), "$caps extraneous caps" ) if $caps;
205 # One and only one trailing underscore is OK.
208 # Now punish anything that's left
210 $remains =~ tr/a-zA-Z0-9//d;
211 my $remains_length = length($remains);
214 50 * $remains_length + &slow_pow( 9, $remains_length ),
217 . ( ( $remains_length == 1 ) ? 'symbol' : 'symbols' )
220 print "\nRaw lameness score is $score\n" if $verbose;
222 # Use an appropriate function to map [0, +inf) to [0, 100)
223 my $percentage = 100 * ( 1 + &Math::Trig::tanh( ( $score - 400 ) / 400 ) ) *
224 ( 1 - 1 / ( 1 + $score / 5 ) ) / 2;
226 my $digits = 2 * ( 2 - &round_up( log( 100 - $percentage ) / log(10) ) );
228 return sprintf "%.${digits}f", $percentage;
231 sub case_shifts ($) {
233 # This is a neat trick suggested by freeside. Thanks freeside!
237 $shifts =~ tr/A-Za-z//cd;
238 $shifts =~ tr/A-Z/U/s;
239 $shifts =~ tr/a-z/l/s;
241 return length($shifts) - 1;
244 sub number_shifts ($) {
247 $shifts =~ tr/A-Za-z0-9//cd;
248 $shifts =~ tr/A-Za-z/l/s;
249 $shifts =~ tr/0-9/n/s;
251 return length($shifts) - 1;
257 return $x**&slow_exponent($y);
260 sub slow_exponent ($) {
263 return 1.3 * $x * ( 1 - &Math::Trig::atan( $x / 6 ) * 2 / $pi );
269 return int($float) + ( ( int($float) == $float ) ? 0 : 1 );
273 my ( $damage, $reason ) = @_;
275 return unless $damage;
278 print "$damage lameness points awarded: $reason\n" if $verbose;
283 # vim:ts=4:sw=4:expandtab:tw=80