#!/usr/bin/env perl
use warnings;
use strict;

use open qw/:std :utf8/;
use Time::HiRes qw/gettimeofday tv_interval/;
use Devel::Size qw/total_size/;

die "Usage: $0 [WORDFILE]\n" unless @ARGV<2;
my $WORDFILE = shift || '/usr/share/dict/words';

my %TRIE; # for trie_search()
my @ALLWORDS; # for re_search()
open my $ifh, '<:utf8', $WORDFILE or die $!;
my $cnt=0;
my $t0_build = [gettimeofday];
while (<$ifh>) {
    chomp;
    next if substr($_,-2) eq "'s";
    push @ALLWORDS, $_;
    my $ptr = \%TRIE; # pointer into trie
    $ptr = ($$ptr{$_} ||= {}) for split //;
    $$ptr{"\0"}=1; # end-of-word marker
    $cnt++;
}
my $build_time_s = tv_interval($t0_build);
close $ifh;
print "Built a trie out of $cnt words in $build_time_s s\n";
print "Size of trie:  ".total_size(\%TRIE)    ." bytes\n";
print "Size of array: ".total_size(\@ALLWORDS)." bytes\n";

# just some stats, comment out if not needed
use List::Util qw/max/;
my $maxlen = max(map {length} @ALLWORDS);
print "Longest word(s): $maxlen letters\n";
print "Those are:\n";
print "\t$_\n" for grep {length==$maxlen} @ALLWORDS;

# user input loop
my ($avg_trie_s,$avg_re_s,$avg_cnt) = (0,0,0);
while(1) {
    print "Enter a word (blank=exit): ";
    chomp(my $word = <STDIN>);
    last unless $word;
    
    # time trie search
    my $t0_trie = [gettimeofday];
    my @found = trie_search($word);
    my $trie_time_s = tv_interval($t0_trie);
    @found = sort @found;
    print "$_\n" for @found;
    print "--- trie: $trie_time_s s\n";
    $avg_trie_s += $trie_time_s;
    
    # time regex search
    my $t0_re = [gettimeofday];
    # swap re_search with xor_search here to test that
    my @re_found = re_search($word);
    my $trie_re_s = tv_interval($t0_re);
    @re_found = sort @re_found;
    print "$_\n" for @re_found;
    print "--- regex: $trie_re_s s\n";
    $avg_re_s += $trie_re_s;
    
    $avg_cnt++;
    # compare results
    warn "Error: found/re_found array length mismatch\n"
        unless @found==@re_found;
    $found[$_] eq $re_found[$_]
        or warn "Error: element $_ mismatch: found=$found[$_], "
            ."re_found=$re_found[$_]\n"
        for 0..$#found;
}
if ($avg_cnt>1) {
    $avg_trie_s /= $avg_cnt;  $avg_re_s /= $avg_cnt;
    print "Avg. trie time=$avg_trie_s s, ",
        "Avg. regex time=$avg_re_s s\n";
}

sub trie_search {
    my ($word) = @_;
    my @found;
    my @lett = split //, $word;
    my $ptr = \%TRIE; # pointer into trie
    for my $i (0..$#lett) { # for each letter in the word
        # inspect all other options at letter $i
        for my $opt (keys %$ptr) {
            next if $opt eq "\0";
            my $tptr = $$ptr{$opt}; # temp pointer
            # walk through the rest of the letters in the trie
            $tptr = $$tptr{$lett[$_]} or last for $i+1..$#lett;
            if ($tptr && $$tptr{"\0"}) { # is this a full word?
                # swap out the one letter
                substr(my $match = $word, $i, 1) = $opt;
                push @found, $match unless $match eq $word;
            }
        }
        $ptr = $$ptr{$lett[$i]}; # walk trie
    }
    return @found;
}

sub re_search {
    my ($word) = @_;
    my $re = join '|', # build a regex for this word
        map {quotemeta(substr($word,0,$_)).'.'
            .quotemeta(substr($word,$_+1))}
        0 .. length($word)-1;
    $re = qr/^(?:$re)$/;
    my @found = grep {/$re/ && $_ ne $word} @ALLWORDS;
    return @found;
}

sub xor_search {
    my ($word) = @_;
    # by AnomalousMonk, http://perlmonks.org/?node_id=1161596
    my @found = grep { length($_)==length($word)
        && ( ($word ^ $_) =~ tr/\x00//c ) == 1 } @ALLWORDS;
    return @found;
}
[download]