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( &::formListReply(0, "Nickometer list for $term ", @list) );
  54
  55     return;
  56   }
  57
  58   my $percentage = &nickometer($term);
  59
  60   if ($percentage =~ /NaN/) {
  61     $percentage = 'off the scale';
  62   } else {
  63     $percentage = sprintf("%0.4f", $percentage);
  64     $percentage =~ s/(\.\d+)0+$/$1/;
  65     $percentage .= '%';
  66   }
  67
  68   if ($::msgType eq 'public') {
  69     &::say("'$term' is $percentage lame, $::who");
  70   } else {
  71     &::msg($::who, "the 'lame nick-o-meter' reading for $term is $percentage, $::who");
  72   }
  73
  74   return;
  75 }
  76
  77 sub nickometer ($) {
  78   my ($text) = @_;
  79   $score = 0;
  80
  81 #  return unless &loadPerlModule("Getopt::Std");
  82   return unless &::loadPerlModule("Math::Trig");
  83
  84   if (!defined $text) {
  85     &::DEBUG("nickometer: arg == NULL. $text");
  86     return;
  87   }
  88
  89   # Deal with special cases (precede with \ to prevent de-k3wlt0k)
  90   my %special_cost = (
  91     '69'                => 500,
  92     'dea?th'            => 500,
  93     'dark'              => 400,
  94     'n[i1]ght'          => 300,
  95     'n[i1]te'           => 500,
  96     'fuck'              => 500,
  97     'sh[i1]t'           => 500,
  98     'coo[l1]'           => 500,
  99     'kew[l1]'           => 500,
 100     'lame'              => 500,
 101     'dood'              => 500,
 102     'dude'              => 500,
 103     '[l1](oo?|u)[sz]er' => 500,
 104     '[l1]eet'           => 500,
 105     'e[l1]ite'          => 500,
 106     '[l1]ord'           => 500,
 107     'pron'              => 1000,
 108     'warez'             => 1000,
 109     'xx'                => 100,
 110     '\[rkx]0'           => 1000,
 111     '\0[rkx]'           => 1000,
 112   );
 113
 114   foreach my $special (keys %special_cost) {
 115     my $special_pattern = $special;
 116     my $raw = ($special_pattern =~ s/^\\//);
 117     my $nick = $text;
 118     unless (defined $raw) {
 119       $nick =~ tr/023457+8/ozeasttb/;
 120     }
 121     &punish($special_cost{$special}, "matched special case /$special_pattern/")
 122       if (defined $nick and $nick =~ /$special_pattern/i);
 123   }
 124
 125   # Allow Perl referencing
 126   $text =~ s/^\\([A-Za-z])/$1/;
 127
 128   # C-- ain't so bad either
 129   $text =~ s/^C--$/C/;
 130
 131   # Punish consecutive non-alphas
 132   $text =~ s/([^A-Za-z0-9]{2,})
 133    /my $consecutive = length($1);
 134     &punish(&slow_pow(10, $consecutive),
 135             "$consecutive total consecutive non-alphas")
 136       if $consecutive;
 137     $1
 138    /egx;
 139
 140   # Remove balanced brackets (and punish a little bit) and punish for unmatched
 141   while ($text =~ s/^([^()]*)   (\() (.*) (\)) ([^()]*)   $/$1$3$5/x ||
 142          $text =~ s/^([^{}]*)   (\{) (.*) (\}) ([^{}]*)   $/$1$3$5/x ||
 143          $text =~ s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
 144   {
 145     print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
 146     &punish(15, 'brackets');
 147   }
 148   my $parentheses = $text =~ tr/(){}[]/(){}[]/;
 149   &punish(&slow_pow(10, $parentheses),
 150           "$parentheses unmatched " .
 151             ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
 152     if $parentheses;
 153
 154   # Punish k3wlt0k
 155   my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
 156   for my $digit (0 .. 9) {
 157     my $occurrences = $text =~ s/$digit/$digit/g || 0;
 158     &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
 159             $occurrences . ' ' .
 160               (($occurrences == 1) ? 'occurrence' : 'occurrences') .
 161               " of $digit")
 162       if $occurrences;
 163   }
 164
 165   # An alpha caps is not lame in middle or at end, provided the first
 166   # alpha is caps.
 167   my $orig_case = $text;
 168   $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
 169
 170   # A caps first alpha is sometimes not lame
 171   $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
 172
 173   # Punish uppercase to lowercase shifts and vice-versa, modulo
 174   # exceptions above
 175   my $case_shifts = &case_shifts($orig_case);
 176   &punish(&slow_pow(9, $case_shifts),
 177           $case_shifts . ' case ' .
 178             (($case_shifts == 1) ? 'shift' : 'shifts'))
 179     if ($case_shifts > 1 && /[A-Z]/);
 180
 181   # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
 182   &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
 183
 184   # Punish letter to numeric shifts and vice-versa
 185   my $number_shifts = &number_shifts($_);
 186   &punish(&slow_pow(9, $number_shifts),
 187           $number_shifts . ' letter/number ' .
 188             (($number_shifts == 1) ? 'shift' : 'shifts'))
 189     if $number_shifts > 1;
 190
 191   # Punish extraneous caps
 192   my $caps = $text =~ tr/A-Z/A-Z/;
 193   &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
 194
 195   # One and only one trailing underscore is OK.
 196   $text =~ s/\_$//;
 197
 198   # Now punish anything that's left
 199   my $remains = $text;
 200   $remains =~ tr/a-zA-Z0-9//d;
 201   my $remains_length = length($remains);
 202
 203   &punish(50 * $remains_length + &slow_pow(9, $remains_length),
 204           $remains_length . ' extraneous ' .
 205             (($remains_length == 1) ? 'symbol' : 'symbols'))
 206     if $remains;
 207
 208   print "\nRaw lameness score is $score\n" if $verbose;
 209
 210   # Use an appropriate function to map [0, +inf) to [0, 100)
 211   my $percentage = 100 *
 212                 (1 + &Math::Trig::tanh(($score-400)/400)) *
 213                 (1 - 1/(1+$score/5)) / 2;
 214
 215   my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
 216
 217   return sprintf "%.${digits}f", $percentage;
 218 }
 219
 220 sub case_shifts ($) {
 221   # This is a neat trick suggested by freeside.  Thanks freeside!
 222
 223   my $shifts = shift;
 224
 225   $shifts =~ tr/A-Za-z//cd;
 226   $shifts =~ tr/A-Z/U/s;
 227   $shifts =~ tr/a-z/l/s;
 228
 229   return length($shifts) - 1;
 230 }
 231
 232 sub number_shifts ($) {
 233   my $shifts = shift;
 234
 235   $shifts =~ tr/A-Za-z0-9//cd;
 236   $shifts =~ tr/A-Za-z/l/s;
 237   $shifts =~ tr/0-9/n/s;
 238
 239   return length($shifts) - 1;
 240 }
 241
 242 sub slow_pow ($$) {
 243   my ($x, $y) = @_;
 244
 245   return $x ** &slow_exponent($y);
 246 }
 247
 248 sub slow_exponent ($) {
 249   my $x = shift;
 250
 251   return 1.3 * $x * (1 - &Math::Trig::atan($x/6) *2/$pi);
 252 }
 253
 254 sub round_up ($) {
 255   my $float = shift;
 256
 257   return int($float) + ((int($float) == $float) ? 0 : 1);
 258 }
 259
 260 sub punish ($$) {
 261   my ($damage, $reason) = @_;
 262
 263   return unless $damage;
 264
 265   $score += $damage;
 266   print "$damage lameness points awarded: $reason\n" if $verbose;
 267 }
 268
 269 1;
 270
 271 # vim:ts=4:sw=4:expandtab:tw=80