encryptio.com

package Mxizer;
#############################################################################
# Mxizer.pm - Mkae tpyos in tetx
# The latest version of this can be found at:
# http://encryptio.com/code/mxizer
#############################################################################
# For those "in the know": This is a BSD-like license. Keep this notice
# intact, no matter what. You can do almost anything else that you wish.
#############################################################################
# Copyright (c) 2007, Chris Kastorff, All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
#     * Redistributions of source code must retain the above copyright
#       notice, this list of conditions, and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * The name Chris Kastorff may not be used to endorse or promote
#       products derived from this software without specific prior written
#       permission.
#############################################################################
use strict;

require Exporter;
our @ISA = qw/ Exporter /;
our @EXPORT = qw/ mxize /;

# shift key on a qwerty keyboard
my %lower = ((map +($_,lc$_), split //, "QWERTYUIOPASDFGHJKLZXCVBNM"),
             (split //, "~`!1\@2#3\$4\%5^6\&7*8(9)0_-+={[}]|\\:;\"'<,>.?/  "));
my %upper = reverse %lower;
@lower{values %lower} = values %lower;
@upper{values %upper} = values %upper;

# keys near another key
my %near = (
    '`' => '1q',      '1' => '`2wq',   '2' => '1qw3',   '3' => '2we4',
    '4' => '3er5',    '5' => '4rt6',   '6' => '5ty7',   '7' => '6yu8',
    '8' => '7ui9',    '9' => '8io0',   '0' => '9op-',   '-' => '0p[=',
    '=' => '-[]',     'q' => '12wsa',  'w' => 'q23esa', 'e' => '34rdsw',
    'r' => '45tfde',  't' => '56ygfr', 'y' => '67uhgt', 'u' => '78ijhy',
    'i' => '89okju',  'o' => '90plki', 'p' => '0-[;lo', '[' => '-=]\';p',
    ']' => '[=\'\\/', '\\' => ']',     'a' => 'qwsz',   's' => 'wedxza',
    'd' => 'erfcxs',  'f' => 'rtgvcd', 'g' => 'tyhbvf', 'h' => 'yugjbn',
    'j' => 'uihknm',  'k' => 'iojlm,', 'l' => 'opk;,.', ';' => 'p[l\'./',
    "'" => '[;/]',    'z' => 'asx',    'x' => 'zsdc ',  'c' => 'xdfv ',
    'v' => 'cfgb ',   'b' => 'vghn ',  'n' => 'bhjm ',  'm' => 'njk, ',
    ',' => 'mkl. ',   '.' => ',l;/',   '/' => '.;\'',
);

my %lefthand  = map { $_, 1 } split //, "`123456qwertyasdfghzxcvb ";
my %righthand = map { $_, 1 } split //, "67890-=tyuiop[\\]hjkl;'bnm,./ ";

sub mxize {
    my ($text) = @_;
    my @chars = split //, " ".$text;

    # turn it into an array with some metadata
    @chars = map +{
        left  => exists($lefthand{ $lower{$_}}),
        right => exists($righthand{$lower{$_}}),
        char => $_,
        islc => ($lower{$_} eq $_),
    }, @chars;

    # swap random chars if they are on alternating hands
    for my $i ( grep { rand > 0.8 } sort { int(rand(3)-1) } 0 .. $#chars-1 ) {
        if ( $chars[$i]{'left'} and $chars[$i+1]{'right'}
                or $chars[$i]{'right'} and $chars[$i+1]{'left'}
                or rand() > 0.01 ) {
            next if ($chars[$i]{'char'} eq " " or $chars[$i]{'char'} eq " ")
                and rand() > 0.2;
            my @in = splice @chars, $i, 2;
            push @in, shift @in; # swap
            splice @chars, $i, 0, @in;
        }
    }

    # if a key is near another key, then sometimes it's replaced or inserted
    for my $i ( grep { rand > 0.95 } sort { int(rand(3)-1) } 0 .. $#chars*2 ) {
        next if $i > $#chars;
        my $insi = $i + (rand > 0.5 ? 1 : 0);
        my $new = $near{$lower{$chars[$i]{'char'}}};
        $new = substr $new, rand(length $new), 1;
        rand > 0.5 ? redo : next if length($new) != 1;
        my $thisislc = $chars[$i]{'islc'};
        my $newchar = {
            left  => exists( $lefthand{$new}  ),
            right => exists( $righthand{$new} ),
            char => ($thisislc ? $lower{$new} : $upper{$new}),
            islc => $thisislc,
        };
        splice @chars, $insi, (rand > 0.25 ? 0 : 1), $newchar;
    }

    # fuck with the capitalization
    for my $i ( sort { int(rand(3)-1) } 0 .. $#chars-1 ) {
        next if rand > 0.3;
        if ( $chars[$i]{'islc'} != $chars[$i+1]{'islc'} ) {
            $chars[$i]{'islc'} = int(rand 1) if rand() > 0.9;
            $chars[$i+1]{'islc'} = $chars[$i]{'islc'} if rand > 0.7;
        }
    }
    for my $c ( @chars ) {
        $c->{'char'} = $c->{'islc'} ? $lower{$c->{'char'}} : $upper{$c->{'char'}};
    }

    # normalize back to an array of one-char strings
    @chars = map { $_->{'char'} } @chars;
    
    # insert random chars
    for my $i ( 0 .. scalar(@chars) ) {
        next if rand > 0.003;
        my $which = int rand @chars;
        my $char = (keys(%lower))[int rand scalar keys %lower];
        splice @chars, $which, 1, $char;
    }

    # remove random chars
    for my $i ( 0 .. scalar(@chars) ) {
        next if rand > 0.015;
        splice @chars, int(rand scalar @chars), 1;
    }

    shift @chars while $chars[0] eq " ";
    return join("", @chars);
}

1;