File Coverage

blib/lib/Lingua/TypoGenerator.pm

Criterion	Covered	Total	%
statement	52	52	100.0
branch	11	14	78.5
condition			n/a
subroutine	5	5	100.0
pod	0	1	0.0
total	68	72	94.4

package Lingua::TypoGenerator;

use 5.006;
use utf8;
use strict;

our $VERSION = '0.01';

use base 'Exporter';
our @EXPORT_OK = qw(typos);

our $HTYPOS = " qwertyuiop asdfghjkl zxcvbnm ýúíó ùìò ÿüïö ûîô";
our @ACCENT_CLASSES = qw(
    aáàâäãå
    eéèêë
    iíìîï
    oóòôöõø
    uúùûü
    yýÿ
    nñ
);


# Takes one word and returns a list of probable typos
sub typos {
    my ($s, %args) = @_;
    my %seen;

    # Typos involving one character
    for (my $i = 0; $i < length $s; ++$i){
	my $c = substr($s, $i, 1);

	next unless $c =~ /\w/;

	my $t = $s; # deletions
	substr($t, $i, 1) = "";
	$seen{$t} = 1;

	# horizontal keyboard typos
	if($HTYPOS =~ /(.)$c(.)/i){
	    if ($1 ne ' '){
		$t = $s;
		substr($t, $i, 1) = $1;
		$seen{$t} = 1;
	    }
	    if ($2 ne ' '){
		$t = $s;
		substr($t, $i, 1) = $2;
		$seen{$t} = 1;
	    }
	}

        if ($args{accents}) {
            for (@ACCENT_CLASSES) {
                my $class = $_;
                if($class =~ s/$c//i){
                    for my $letter (split(//, $class)){
                        $t = $s;
                        substr($t, $i, 1) = $letter;
                        $seen{$t} = 1;
                    }
                }
            }
        }
    }

    # Typos involving a pair of adjacent characters
    for (my $i = 1; $i < length $s; ++$i){
	my $t = $s;

	next unless substr($t, $i - 1, 2) =~ /\w\w/;

	my $c = substr $t, $i, 1; # transpositions
	substr($t, $i, 1) = substr($t, $i - 1, 1);
	substr($t, $i - 1, 1) = $c;
	$seen{$t} = 1;

	$t = $s;  # duplications with replacement
	substr($t, $i, 1) = substr($t, $i - 1, 1);
	$seen{$t} = 1;

	$t = $s;  # duplications with insertion
	substr($t, $i, 0) = substr($t, $i - 1, 1);
	$seen{$t} = 1;
    }

    delete $seen{$s}; # make sure to exclude original word!

    return sort keys %seen;
}

1;

__END__