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 use strict;
  12
  13 my $pi          = 3.14159265;
  14 my $score       = 0;
  15 my $verbose     = 0;
  16
  17 sub nickometer ($) {
  18 #  return unless &loadPerlModule("Getopt::Std");
  19   return unless &loadPerlModule("Math::Trig");
  20
  21   local $_ = shift;
  22   $score = 0;
  23
  24   if (!defined) {
  25     &DEBUG("nickometer: arg == NULL.");
  26     return;
  27   }
  28
  29   # Deal with special cases (precede with \ to prevent de-k3wlt0k)
  30   my %special_cost = (
  31         '69'                    => 500,
  32         'dea?th'                => 500,
  33         'dark'                  => 400,
  34         'n[i1]ght'              => 300,
  35         'n[i1]te'               => 500,
  36         'fuck'                  => 500,
  37         'sh[i1]t'               => 500,
  38         'coo[l1]'               => 500,
  39         'kew[l1]'               => 500,
  40         'lame'                  => 500,
  41         'dood'                  => 500,
  42         'dude'                  => 500,
  43         '[l1](oo?|u)[sz]er'     => 500,
  44         '[l1]eet'               => 500,
  45         'e[l1]ite'              => 500,
  46         '[l1]ord'               => 500,
  47         'pron'                  => 1000,
  48         'warez'                 => 1000,
  49         'xx'                    => 100,
  50         '\[rkx]0'               => 1000,
  51         '\0[rkx]'               => 1000,
  52   );
  53
  54   foreach my $special (keys %special_cost) {
  55     my $special_pattern = $special;
  56     my $raw = ($special_pattern =~ s/^\\//);
  57     my $nick = $_;
  58     unless (defined $raw) {
  59       $nick =~ tr/023457+8/ozeasttb/;
  60     }
  61     &punish($special_cost{$special}, "matched special case /$special_pattern/")
  62       if (defined $nick and $nick =~ /$special_pattern/i);
  63   }
  64
  65   # Allow Perl referencing
  66   s/^\\([A-Za-z])/$1/;
  67
  68   # C-- ain't so bad either
  69   s/^C--$/C/;
  70
  71   # Punish consecutive non-alphas
  72   s/([^A-Za-z0-9]{2,})
  73    /my $consecutive = length($1);
  74     &punish(&slow_pow(10, $consecutive),
  75             "$consecutive total consecutive non-alphas")
  76       if $consecutive;
  77     $1
  78    /egx;
  79
  80   # Remove balanced brackets (and punish a little bit) and punish for unmatched
  81   while (s/^([^()]*)   (\() (.*) (\)) ([^()]*)   $/$1$3$5/x ||
  82          s/^([^{}]*)   (\{) (.*) (\}) ([^{}]*)   $/$1$3$5/x ||
  83          s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
  84   {
  85     print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
  86     &punish(15, "brackets");
  87   }
  88   my $parentheses = tr/(){}[]/(){}[]/;
  89   &punish(&slow_pow(10, $parentheses),
  90           "$parentheses unmatched " .
  91             ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
  92     if $parentheses;
  93
  94   # Punish k3wlt0k
  95   my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
  96   for my $digit (0 .. 9) {
  97     my $occurrences = s/$digit/$digit/g || 0;
  98     &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
  99             $occurrences . ' ' .
 100               (($occurrences == 1) ? 'occurrence' : 'occurrences') .
 101               " of $digit")
 102       if $occurrences;
 103   }
 104
 105   # An alpha caps is not lame in middle or at end, provided the first
 106   # alpha is caps.
 107   my $orig_case = $_;
 108   s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
 109
 110   # A caps first alpha is sometimes not lame
 111   s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
 112
 113   # Punish uppercase to lowercase shifts and vice-versa, modulo
 114   # exceptions above
 115   my $case_shifts = &case_shifts($orig_case);
 116   &punish(&slow_pow(9, $case_shifts),
 117           $case_shifts . ' case ' .
 118             (($case_shifts == 1) ? 'shift' : 'shifts'))
 119     if ($case_shifts > 1 && /[A-Z]/);
 120
 121   # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
 122   &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
 123
 124   # Punish letter to numeric shifts and vice-versa
 125   my $number_shifts = &number_shifts($_);
 126   &punish(&slow_pow(9, $number_shifts),
 127           $number_shifts . ' letter/number ' .
 128             (($number_shifts == 1) ? 'shift' : 'shifts'))
 129     if $number_shifts > 1;
 130
 131   # Punish extraneous caps
 132   my $caps = tr/A-Z/A-Z/;
 133   &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
 134
 135   # One and only one trailing underscore is OK.
 136   s/\_$//;
 137
 138   # Now punish anything that's left
 139   my $remains = $_;
 140   $remains =~ tr/a-zA-Z0-9//d;
 141   my $remains_length = length($remains);
 142
 143   &punish(50 * $remains_length + &slow_pow(9, $remains_length),
 144           $remains_length . ' extraneous ' .
 145             (($remains_length == 1) ? 'symbol' : 'symbols'))
 146     if $remains;
 147
 148   print "\nRaw lameness score is $score\n" if $verbose;
 149
 150   # Use an appropriate function to map [0, +inf) to [0, 100)
 151   my $percentage = 100 *
 152                 (1 + tanh(($score-400)/400)) *
 153                 (1 - 1/(1+$score/5)) / 2;
 154
 155   my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
 156
 157   return sprintf "%.${digits}f", $percentage;
 158 }
 159
 160 sub case_shifts ($) {
 161   # This is a neat trick suggested by freeside.  Thanks freeside!
 162
 163   my $shifts = shift;
 164
 165   $shifts =~ tr/A-Za-z//cd;
 166   $shifts =~ tr/A-Z/U/s;
 167   $shifts =~ tr/a-z/l/s;
 168
 169   return length($shifts) - 1;
 170 }
 171
 172 sub number_shifts ($) {
 173   my $shifts = shift;
 174
 175   $shifts =~ tr/A-Za-z0-9//cd;
 176   $shifts =~ tr/A-Za-z/l/s;
 177   $shifts =~ tr/0-9/n/s;
 178
 179   return length($shifts) - 1;
 180 }
 181
 182 sub slow_pow ($$) {
 183   my ($x, $y) = @_;
 184
 185   return $x ** &slow_exponent($y);
 186 }
 187
 188 sub slow_exponent ($) {
 189   my $x = shift;
 190
 191   return 1.3 * $x * (1 - atan($x/6) *2/$pi);
 192 }
 193
 194 sub round_up ($) {
 195   my $float = shift;
 196
 197   return int($float) + ((int($float) == $float) ? 0 : 1);
 198 }
 199
 200 sub punish ($$) {
 201   my ($damage, $reason) = @_;
 202
 203   return unless $damage;
 204
 205   $score += $damage;
 206   print "$damage lameness points awarded: $reason\n" if $verbose;
 207 }
 208
 209 1;