| NamePros Member Join Date: Dec 2005
Posts: 43
| typos - perl
PHP Code: use strict;
# http://www.spiderninja.com/
# ninja@spiderninja.com
my @a = qw(spider ninja);
for (@a) {
print make_typos($_), "\n";
}
sub make_typos {
my $word = shift;
my @typos;
push @typos, skip_letter($word);
push @typos, double_letters($word);
push @typos, reverse_letters($word);
push @typos, skip_spaces($word);
push @typos, missed_key($word);
push @typos, inserted_key($word);
return join ",", map { "\"$_\"" } @typos;
}
sub skip_letter {
my @l = split(//, shift);
my @a;
for (my $x = 0; $x < @l; $x++) {
next if ($l[$x] eq ' ');
my $s;
for (my $y = 0; $y < @l; $y++) {
????: NamePros.com http://www.namepros.com/code/311233-typos-perl.html
next if ($y == $x);
$s .= $l[$y];
}
push @a, $s;
}
return @a;
}
sub double_letters {
my @l = split(//, shift);
my @a;
for (my $x = 0; $x < @l; $x++) {
next if ($l[$x] eq ' ');
my $s;
for (my $y = 0; $y < @l; $y++) {
$s .= $l[$y];
if ($y == $x) {
$s .= $l[$y];
}
}
push @a, $s;
}
return @a;
}
sub reverse_letters {
my @l = split(//, shift);
my @a;
for (my $x = 0; $x < @l - 1; $x++) {
next if ($l[$x] eq ' ' || $l[$x] eq $l[$x+1]);
????: NamePros.com http://www.namepros.com/showthread.php?t=311233
my $s;
for (my $y = 0; $y < @l; $y++) {
if ($y == $x && $x < @l) {
$s .= $l[$y+1];
} elsif ($y == $x+1) {
$s .= $l[$y-1];
} else {
$s .= $l[$y];
}
}
push @a, $s;
}
return @a;
}
sub skip_spaces {
my @l = split(//, shift);
my (@whitespace_pos, $i);
for my $letter (@l) {
if ($letter eq ' ') {
push @whitespace_pos, $i;
}
$i++
}
my @a;
for (@whitespace_pos) {
my $s;
for my $x (0 .. $#l) {
if ($_ == $x) {
next;
} else {
$s .= $l[$x];
}
}
push @a, $s;
}
return @a;
}
sub missed_key {
my @l = split(//, lc(shift));
my %atoz = get_alphabet();
my @a;
for (my $x = 0; $x < @l; $x++) {
next if ($l[$x] eq ' ' || !$atoz{$l[$x]});
for (my $y = 0; $y < @{$atoz{$l[$x]}}; $y++) {
my $s;
for (my $z = 0; $z < @l; $z++) {
if ($x == $z) {
$s .= ${$atoz{$l[$x]}}[$y];
} else {
$s .= $l[$z];
}
}
push @a, $s;
}
}
return @a;
}
sub inserted_key {
my @l = split(//, lc(shift));
my @a;
my %atoz = get_alphabet();
for (my $x = 0; $x < @l; $x++) {
next if ($l[$x] eq ' ' || !$atoz{$l[$x]});
for (my $y = 0; $y < @{$atoz{$l[$x]}}; $y++) {
my ($axbc, $abxc);
for (my $z = 0; $z < @l; $z++) {
if ($x == $z) {
$axbc .= ${$atoz{$l[$x]}}[$y];
$axbc .= $l[$z];
$abxc .= $l[$z];
$abxc .= ${$atoz{$l[$x]}}[$y];
} else {
$axbc .= $l[$z];
$abxc .= $l[$z];
}
}
push @a, $axbc;
push @a, $abxc;
}
}
return @a;
}
sub get_alphabet {
my %alphabet = (q => ["1", "2", "w", "s", "a"],
w => ["q", "2", "3", "e", "d", "s", "a"],
e => ["w", "3", "4", "r", "f", "d", "s"],
r => ["e", "4", "5", "t", "g", "f", "d"],
t => ["r", "5", "6", "y", "h", "g", "f"],
y => ["t", "6", "7", "u", "j", "h", "g"],
u => ["y", "7", "8", "i", "k", "j", "h"],
i => ["u", "8", "9", "o", "l", "k", "j"],
o => ["i", "9", "0", "p", "l", "k"],
p => ["o", "0", "l"],
a => ["q", "w", "s", "x", "z"],
s => ["a", "w", "e", "d", "x", "z"],
d => ["s", "e", "r", "f", "c", "x"],
f => ["d", "r", "t", "g", "v", "c"],
g => ["f", "t", "y", "h", "b", "v"],
h => ["g", "y", "u", "j", "n", "b"],
j => ["h", "u", "i", "k", "m", "n"],
k => ["j", "i", "o", "l", "m"],
l => ["k", "o", "p"],
z => ["a", "s", "x"],
x => ["z", "s", "d", "c"],
c => ["x", "d", "f", "v"],
v => ["c", "f", "g", "b"],
b => ["v", "g", "h", "n"],
n => ["b", "h", "j", "m"],
m => ["n", "j", "k"],
);
return %alphabet;
}
ahhhh...beautiful ;-) I should rewrite it in PHP and post again
Last edited by spiderninja; 03-30-2007 at 09:29 PM.
|
03-30-2007, 07:03 PM
