Created
November 12, 2012 10:35
-
-
Save stfnm/4058572 to your computer and use it in GitHub Desktop.
Nickometer
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/usr/bin/perl -w | |
# | |
# Lame-o-Nickometer backend | |
# | |
# (c) 1998 Adam Spiers <adam.spiers@new.ox.ac.uk> | |
# | |
# You may do whatever you want with this code, but give me credit. | |
# | |
# $Id: nickometer.pl,v 1.3 1998/09/05 19:58:15 adam Exp $ | |
# | |
use strict; | |
use Getopt::Std; | |
use Math::Trig; | |
use vars qw($VERSION $score $verbose); | |
$VERSION = '$Revision: 1.3 $'; # ' | |
$VERSION =~ s/^.*?([\d.]+).*?$/$1/; | |
sub nickometer ($) { | |
local $_ = shift; | |
local $score = 0; | |
# Deal with special cases (precede with \ to prevent de-k3wlt0k) | |
my %special_cost = ( | |
'69' => 500, | |
'dea?th' => 500, | |
'dark' => 400, | |
'n[i1]ght' => 300, | |
'n[i1]te' => 500, | |
'fuck' => 500, | |
'sh[i1]t' => 500, | |
'coo[l1]' => 500, | |
'kew[l1]' => 500, | |
'lame' => 500, | |
'dood' => 500, | |
'dude' => 500, | |
'[l1](oo?|u)[sz]er' => 500, | |
'[l1]eet' => 500, | |
'e[l1]ite' => 500, | |
'[l1]ord' => 500, | |
'pron' => 1000, | |
'warez' => 1000, | |
'xx' => 100, | |
'\[rkx]0' => 1000, | |
'\0[rkx]' => 1000, | |
); | |
foreach my $special (keys %special_cost) { | |
my $special_pattern = $special; | |
my $raw = ($special_pattern =~ s/^\\//); | |
my $nick = $_; | |
unless ($raw) { | |
$nick =~ tr/023457+8/ozeasttb/; | |
} | |
&punish($special_cost{$special}, "matched special case /$special_pattern/") | |
if $nick =~ /$special_pattern/i; | |
} | |
# Allow Perl referencing | |
s/^\\([A-Za-z])/$1/; | |
# Keep me safe from Pudge ;-) | |
s/\^(pudge)/$1/i; | |
# C-- ain't so bad either | |
s/^C--$/C/; | |
# Punish consecutive non-alphas | |
s/([^A-Za-z0-9]{2,}) | |
/my $consecutive = length($1); | |
&punish(&slow_pow(10, $consecutive), | |
"$consecutive total consecutive non-alphas") | |
if $consecutive; | |
$1 | |
/egx; | |
# Remove balanced brackets and punish for unmatched | |
while (s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x || | |
s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x || | |
s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x) | |
{ | |
print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose; | |
} | |
my $parentheses = tr/(){}[]/(){}[]/; | |
&punish(&slow_pow(10, $parentheses), | |
"$parentheses unmatched " . | |
($parentheses == 1 ? 'parenthesis' : 'parentheses')) | |
if $parentheses; | |
# Punish k3wlt0k | |
my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2); | |
for my $digit (0 .. 9) { | |
my $occurrences = s/$digit/$digit/g || 0; | |
&punish($k3wlt0k_weights[$digit] * $occurrences * 30, | |
$occurrences . ' ' . | |
(($occurrences == 1) ? 'occurrence' : 'occurrences') . | |
" of $digit") | |
if $occurrences; | |
} | |
# An alpha caps is not lame in middle or at end, provided the first | |
# alpha is caps. | |
my $orig_case = $_; | |
s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/; | |
# A caps first alpha is sometimes not lame | |
s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/; | |
# Punish uppercase to lowercase shifts and vice-versa, modulo | |
# exceptions above | |
my $case_shifts = &case_shifts($orig_case); | |
&punish(&slow_pow(9, $case_shifts), | |
$case_shifts . ' case ' . | |
(($case_shifts == 1) ? 'shift' : 'shifts')) | |
if ($case_shifts > 1 && /[A-Z]/); | |
# Punish lame endings (TorgoX, WraithX et al. might kill me for this :-) | |
&punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/; | |
# Punish letter to numeric shifts and vice-versa | |
my $number_shifts = &number_shifts($_); | |
&punish(&slow_pow(9, $number_shifts), | |
$number_shifts . ' letter/number ' . | |
(($number_shifts == 1) ? 'shift' : 'shifts')) | |
if $number_shifts > 1; | |
# Punish extraneous caps | |
my $caps = tr/A-Z/A-Z/; | |
&punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps; | |
# Now punish anything that's left | |
my $remains = $_; | |
$remains =~ tr/a-zA-Z0-9//d; | |
my $remains_length = length($remains); | |
&punish(50 * $remains_length + &slow_pow(9, $remains_length), | |
$remains_length . ' extraneous ' . | |
(($remains_length == 1) ? 'symbol' : 'symbols')) | |
if $remains; | |
print "\nRaw lameness score is $score\n" if $verbose; | |
# Use an appropriate function to map [0, +inf) to [0, 100) | |
my $percentage = 100 * | |
(1 + tanh(($score-400)/400)) * | |
(1 - 1/(1+$score/5)) / 2; | |
my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10))); | |
return sprintf "%.${digits}f", $percentage; | |
} | |
sub case_shifts ($) { | |
# This is a neat trick suggested by freeside. Thanks freeside! | |
my $shifts = shift; | |
$shifts =~ tr/A-Za-z//cd; | |
$shifts =~ tr/A-Z/U/s; | |
$shifts =~ tr/a-z/l/s; | |
return length($shifts) - 1; | |
} | |
sub number_shifts ($) { | |
my $shifts = shift; | |
$shifts =~ tr/A-Za-z0-9//cd; | |
$shifts =~ tr/A-Za-z/l/s; | |
$shifts =~ tr/0-9/n/s; | |
return length($shifts) - 1; | |
} | |
sub slow_pow ($$) { | |
my ($x, $y) = @_; | |
return $x ** &slow_exponent($y); | |
} | |
sub slow_exponent ($) { | |
my $x = shift; | |
return 1.3 * $x * (1 - atan($x/6) *2/pi); | |
} | |
sub round_up ($) { | |
my $float = shift; | |
return int($float) + ((int($float) == $float) ? 0 : 1); | |
} | |
sub punish ($$) { | |
my ($damage, $reason) = @_; | |
return unless $damage; | |
$score += $damage; | |
print "$damage lameness points awarded: $reason\n" if $verbose; | |
} | |
1; | |
################################################################################ | |
################################################################################ | |
die "Usage: perl " . __FILE__ . "somenick" if ($#ARGV+1 < 1); | |
my $nick = $ARGV[0]; | |
print "`$nick' is " . nickometer($nick) . " % lame."; |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment