src/Modules/nickometer.pl

   1 #
   2 # Lame-o-Nickometer backend
   3 #
   4 # (c) 1998 Adam Spiers <adam.spiers@new.ox.ac.uk>
   5 #
   6 # You may do whatever you want with this code, but give me credit.
   7 #
   8 # $Id$
   9 #
  10
  11 package nickometer;
  12
  13 use strict;
  14
  15 my $pi      = 3.14159265;
  16 my $score   = 0;
  17 my $verbose = 0;
  18
  19 sub query {
  20     my ($message) = @_;
  21
  22     my $term = ( lc $message eq 'me' ) ? $::who : $message;
  23
  24     if ( $term =~ /^$::mask{chan}$/ ) {
  25         &::status("Doing nickometer for chan $term.");
  26
  27         if ( !&::validChan($term) ) {
  28             &::msg( $::who, "error: channel is invalid." );
  29             return;
  30         }
  31
  32         # step 1.
  33         my %nickometer;
  34         foreach ( keys %{ $::channels{ lc $term }{''} } ) {
  35             my $str = $_;
  36             if ( !defined $str ) {
  37                 &WARN("nickometer: nick in chan $term undefined?");
  38                 next;
  39             }
  40
  41             my $value = &nickometer($str);
  42             $nickometer{$value}{$str} = 1;
  43         }
  44
  45         # step 2.
  46         ### TODO: compact with map?
  47         my @list;
  48         foreach ( sort { $b <=> $a } keys %nickometer ) {
  49             my $str = join( ', ', sort keys %{ $nickometer{$_} } );
  50             push( @list, "$str ($_%)" );
  51         }
  52
  53         &::performStrictReply(
  54             &::formListReply( 0, "Nickometer list for $term ", @list ) );
  55
  56         return;
  57     }
  58
  59     my $percentage = &nickometer($term);
  60
  61     if ( $percentage =~ /NaN/ ) {
  62         $percentage = 'off the scale';
  63     }
  64     else {
  65         $percentage = sprintf( "%0.4f", $percentage );
  66         $percentage =~ s/(\.\d+)0+$/$1/;
  67         $percentage .= '%';
  68     }
  69
  70     if ( $::msgType eq 'public' ) {
  71         &::say("'$term' is $percentage lame, $::who");
  72     }
  73     else {
  74         &::msg( $::who,
  75             "the 'lame nick-o-meter' reading for $term is $percentage, $::who"
  76         );
  77     }
  78
  79     return;
  80 }
  81
  82 sub nickometer ($) {
  83     my ($text) = @_;
  84     $score = 0;
  85
  86     #  return unless &loadPerlModule("Getopt::Std");
  87     return unless &::loadPerlModule("Math::Trig");
  88
  89     if ( !defined $text ) {
  90         &::DEBUG("nickometer: arg == NULL. $text");
  91         return;
  92     }
  93
  94     # Deal with special cases (precede with \ to prevent de-k3wlt0k)
  95     my %special_cost = (
  96         '69'                => 500,
  97         'dea?th'            => 500,
  98         'dark'              => 400,
  99         'n[i1]ght'          => 300,
 100         'n[i1]te'           => 500,
 101         'fuck'              => 500,
 102         'sh[i1]t'           => 500,
 103         'coo[l1]'           => 500,
 104         'kew[l1]'           => 500,
 105         'lame'              => 500,
 106         'dood'              => 500,
 107         'dude'              => 500,
 108         '[l1](oo?|u)[sz]er' => 500,
 109         '[l1]eet'           => 500,
 110         'e[l1]ite'          => 500,
 111         '[l1]ord'           => 500,
 112         'pron'              => 1000,
 113         'warez'             => 1000,
 114         'xx'                => 100,
 115         '\[rkx]0'           => 1000,
 116         '\0[rkx]'           => 1000,
 117     );
 118
 119     foreach my $special ( keys %special_cost ) {
 120         my $special_pattern = $special;
 121         my $raw             = ( $special_pattern =~ s/^\\// );
 122         my $nick            = $text;
 123         unless ( defined $raw ) {
 124             $nick =~ tr/023457+8/ozeasttb/;
 125         }
 126         &punish( $special_cost{$special},
 127             "matched special case /$special_pattern/" )
 128           if ( defined $nick and $nick =~ /$special_pattern/i );
 129     }
 130
 131     # Allow Perl referencing
 132     $text =~ s/^\\([A-Za-z])/$1/;
 133
 134     # C-- ain't so bad either
 135     $text =~ s/^C--$/C/;
 136
 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")
 142       if $consecutive;
 143     $1
 144    /egx;
 145
 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 )
 150     {
 151         print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
 152         &punish( 15, 'brackets' );
 153     }
 154     my $parentheses = $text =~ tr/(){}[]/(){}[]/;
 155     &punish(
 156         &slow_pow( 10, $parentheses ),
 157         "$parentheses unmatched "
 158           . ( $parentheses == 1 ? 'parenthesis' : 'parentheses' )
 159     ) if $parentheses;
 160
 161     # Punish k3wlt0k
 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;
 165         &punish(
 166             $k3wlt0k_weights[$digit] * $occurrences * 30,
 167             $occurrences . ' '
 168               . ( ( $occurrences == 1 ) ? 'occurrence' : 'occurrences' )
 169               . " of $digit"
 170         ) if $occurrences;
 171     }
 172
 173     # An alpha caps is not lame in middle or at end, provided the first
 174     # alpha is caps.
 175     my $orig_case = $text;
 176     $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
 177
 178     # A caps first alpha is sometimes not lame
 179     $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
 180
 181     # Punish uppercase to lowercase shifts and vice-versa, modulo
 182     # exceptions above
 183     my $case_shifts = &case_shifts($orig_case);
 184     &punish(
 185         &slow_pow( 9, $case_shifts ),
 186         $case_shifts . ' case ' . ( ( $case_shifts == 1 ) ? 'shift' : 'shifts' )
 187     ) if ( $case_shifts > 1 && /[A-Z]/ );
 188
 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]*$/;
 191
 192     # Punish letter to numeric shifts and vice-versa
 193     my $number_shifts = &number_shifts($_);
 194     &punish(
 195         &slow_pow( 9, $number_shifts ),
 196         $number_shifts
 197           . ' letter/number '
 198           . ( ( $number_shifts == 1 ) ? 'shift' : 'shifts' )
 199     ) if $number_shifts > 1;
 200
 201     # Punish extraneous caps
 202     my $caps = $text =~ tr/A-Z/A-Z/;
 203     &punish( &slow_pow( 7, $caps ), "$caps extraneous caps" ) if $caps;
 204
 205     # One and only one trailing underscore is OK.
 206     $text =~ s/\_$//;
 207
 208     # Now punish anything that's left
 209     my $remains = $text;
 210     $remains =~ tr/a-zA-Z0-9//d;
 211     my $remains_length = length($remains);
 212
 213     &punish(
 214         50 * $remains_length + &slow_pow( 9, $remains_length ),
 215         $remains_length
 216           . ' extraneous '
 217           . ( ( $remains_length == 1 ) ? 'symbol' : 'symbols' )
 218     ) if $remains;
 219
 220     print "\nRaw lameness score is $score\n" if $verbose;
 221
 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;
 225
 226     my $digits = 2 * ( 2 - &round_up( log( 100 - $percentage ) / log(10) ) );
 227
 228     return sprintf "%.${digits}f", $percentage;
 229 }
 230
 231 sub case_shifts ($) {
 232
 233     # This is a neat trick suggested by freeside.  Thanks freeside!
 234
 235     my $shifts = shift;
 236
 237     $shifts =~ tr/A-Za-z//cd;
 238     $shifts =~ tr/A-Z/U/s;
 239     $shifts =~ tr/a-z/l/s;
 240
 241     return length($shifts) - 1;
 242 }
 243
 244 sub number_shifts ($) {
 245     my $shifts = shift;
 246
 247     $shifts =~ tr/A-Za-z0-9//cd;
 248     $shifts =~ tr/A-Za-z/l/s;
 249     $shifts =~ tr/0-9/n/s;
 250
 251     return length($shifts) - 1;
 252 }
 253
 254 sub slow_pow ($$) {
 255     my ( $x, $y ) = @_;
 256
 257     return $x**&slow_exponent($y);
 258 }
 259
 260 sub slow_exponent ($) {
 261     my $x = shift;
 262
 263     return 1.3 * $x * ( 1 - &Math::Trig::atan( $x / 6 ) * 2 / $pi );
 264 }
 265
 266 sub round_up ($) {
 267     my $float = shift;
 268
 269     return int($float) + ( ( int($float) == $float ) ? 0 : 1 );
 270 }
 271
 272 sub punish ($$) {
 273     my ( $damage, $reason ) = @_;
 274
 275     return unless $damage;
 276
 277     $score += $damage;
 278     print "$damage lameness points awarded: $reason\n" if $verbose;
 279 }
 280
 281 1;
 282
 283 # vim:ts=4:sw=4:expandtab:tw=80