File Coverage

blib/lib/Lingua/Anagrams.pm

Criterion	Covered	Total	%
statement	347	349	99.4
branch	118	140	84.2
condition	33	44	75.0
subroutine	30	30	100.0
pod	5	5	100.0
total	533	568	93.8

package Lingua::Anagrams;
$Lingua::Anagrams::VERSION = '0.018';
# ABSTRACT: pure Perl anagram finder

use strict;
use warnings;

use List::MoreUtils qw(uniq);


# don't cache anagrams for bigger character counts than this
our $LIMIT = 20;

# some global variables to be localized
# used to limit time spent copying values
our ( $limit, $known, $trie, %cache, $cleaner, @jumps, @indices );


sub new {
    my $class = shift;
    my $wl    = shift;
    die 'first parameter expected to be an array reference'
      unless ref $wl eq 'ARRAY';
    my %params = _make_opts(@_);
    $class = ref $class || $class;
    local $cleaner = $params{clean} // \&_clean;
    my @word_lists;
    if ( ref $wl->[0] eq 'ARRAY' ) {
        @word_lists = @$wl;
    }
    else {
        @word_lists = ($wl);
    }
    _validate_lists( \@word_lists );
    my $translator = { '' => 0 };
    $translator->{$_} = scalar keys %$translator for @{ $word_lists[-1] };
    my $offset;    # used to reduce number of undef cells in tries and elsewhere
    for my $w ( @{ $word_lists[-1] } ) {
        my @ords = map ord, split //, $w;
        for my $o (@ords) {
            if ( defined $offset ) {
                $offset = $o if $o < $offset;
            }
            else {
                $offset = $o;
            }
        }
    }
    --$offset;
    my @tries;
    for my $words (@word_lists) {
        my ( $trie, $known ) = _trieify( $words, $translator, $offset );
        push @tries, [ $trie, $known ];
    }
    $translator = [ '', @{ $word_lists[-1] } ];
    return bless {
        limit  => $params{limit}  // $LIMIT,
        sorted => $params{sorted} // 0,
        min    => $params{min},
        clean  => $cleaner,
        tries  => \@tries,
        translator => $translator,
        offset     => $offset,
      },
      $class;
}

# there should be no empty lists and each list should be subsumed
# by the next
sub _validate_lists {
    my $lists = shift;
    for my $i ( 0 .. $#$lists ) {
        my @list = uniq grep length,
          map { my $v = $_ // ''; $cleaner->($v); $v } @{ $lists->[$i] };
        die 'empty list' unless @list;
        $lists->[$i] = \@list;
    }
    for my $i ( 1 .. $#$lists ) {
        my ( $prior, $list ) = @$lists[ $i - 1, $i ];
        die 'lists misordered by length' if @$prior >= @$list;
        my %set = map { $_ => 1 } @$list;
        for my $word (@$prior) {
            die 'smaller lists must be subsumed by larger' unless $set{$word};
        }
    }
}

sub _trieify {
    my ( $words, $translator, $offset ) = @_;
    my $base = [];
    my @known;
    for my $word (@$words) {
        next unless length( $word // '' );
        my @chars = map { ord($_) - $offset } split //, $word;
        _learn( \@known, \@chars );
        _add( $base, \@chars, $word, $translator );
    }
    return $base, \@known;
}

sub _learn {
    my ( $known, $new ) = @_;
    for my $i (@$new) {
        $known->[$i] ||= 1;
    }
}

sub _add {
    my ( $base, $chars, $word, $translator ) = @_;
    my $i = shift @$chars;
    if ($i) {
        my $next = $base->[$i] //= [];
        _add( $next, $chars, $word, $translator );
    }
    else {    # store values in trie at the zero index
        $base->[0] = $translator->{$word};
    }
}

# walk the trie looking for words you can make out of the current character count
sub _words_in {
    my ( $counts, $total ) = @_;
    my @words;
    my @stack = ( [ 0, $trie ] );
    while (1) {
        my ( $c, $level ) = @{ $stack[-1] };
        if ( $c == -1 || $c >= @$level ) {
            last if @stack == 1;
            pop @stack;
            ++$total;
            $c = \( $stack[-1][0] );
            ++$counts->[$$c];
            $$c = $jumps[$$c];
        }
        else {
            my $l = $level->[$c];
            if ($l) {    # trie holds corresponding node
                if ($c) {    # character
                    if ( $counts->[$c] ) {
                        push @stack, [ 0, $l ];
                        --$counts->[$c];
                        --$total;
                    }
                    else {
                        $stack[-1][0] = $jumps[$c];
                    }
                }
                else {       # terminal
                    push @words, [ $l, [@$counts] ];
                    if ($total) {
                        $stack[-1][0] = $jumps[$c];
                    }
                    else {
                        pop @stack;
                        ++$total;
                        $c = \( $stack[-1][0] );
                        ++$counts->[$$c];
                        $$c = $jumps[$$c];
                    }
                }
            }
            else {    # try the next possible character
                $stack[-1][0] = $jumps[$c];
            }
        }
    }
    \@words;
}


sub anagrams {
    my $self   = shift;
    my $phrase = shift;
    my %opts   = _make_opts(@_);
    local ( $limit, $cleaner ) = @$self{qw(limit clean)};
    $cleaner->($phrase);
    return () unless length $phrase;
    my ( $sort, $min );

    if ( exists $opts{sorted} ) {
        $sort = $opts{sorted};
    }
    else {
        $sort = $self->{sorted};
    }
    if ( exists $opts{min} ) {
        $min = $opts{min};
    }
    else {
        $min = $self->{min};
    }
    my $i = $opts{start_list} // 0;
    my @pairs = @{ $self->{tries} };
    if ($i) {
        die "impossible index for start list: $i" unless defined $pairs[$i];
        $i = @pairs + $i if $i < 0;
        @pairs = @pairs[ $i .. $#pairs ];
    }
    my $offset     = $self->{offset};
    my $counts     = _counts( $phrase, $offset );
    my @translator = @{ $self->{translator} };
    local @jumps   = _jumps($counts);
    local @indices = _indices($counts);
    my @anagrams;
    for my $pair (@pairs) {
        local ( $trie, $known ) = @$pair;
        next unless _all_known($counts);
        local %cache = ();
        @anagrams = _anagramize($counts);
        next unless @anagrams;
        next if $min and @anagrams < $min;
        last;
    }
    @anagrams = map { [ @translator[@$_] ] } @anagrams;
    if ($sort) {
        @anagrams = sort {
            my $ordered = @$a <= @$b ? 1 : -1;
            my ( $d, $e ) = $ordered == 1 ? ( $a, $b ) : ( $b, $a );
            for ( 0 .. $#$d ) {
                my $c = $d->[$_] cmp $e->[$_];
                return $ordered * $c if $c;
            }
            -$ordered;
        } map { [ sort @$_ ] } @anagrams;
    }
    return @anagrams;
}

sub _make_opts {
    if ( @_ == 1 ) {
        my $r = shift;
        die 'options expected to be key value pairs or a hash ref'
          unless 'HASH' eq ref $r;
        return %$r;
    }
    else {
        return @_;
    }
}


our $null = sub { };

sub iterator {
    my $self   = shift;
    my $phrase = shift;
    my %opts   = _make_opts(@_);
    $opts{sorted} //= $self->{sorted};
    $self->{clean}->($phrase);
    my $i = $opts{start_list} // 0;
    my @pairs = @{ $self->{tries} };
    if ($i) {
        die "impossible index for start list: $i" unless defined $pairs[$i];
        $i = @pairs + $i if $i < 0;
        @pairs = @pairs[ $i .. $#pairs ];
    }
    return $null unless length $phrase;
    return _super_iterator( \@pairs, $phrase, \%opts,
        @$self{qw(translator offset)} );
}

# iterator that converts word indices back to words
sub _super_iterator {
    my ( $tries, $phrase, $opts, $translator, $offset ) = @_;
    my $counts = _counts( $phrase, $offset );
    my @j      = _jumps($counts);
    my @ix     = _indices($counts);
    my $i      = _iterator( $tries, $counts, $opts );
    my %c;
    return sub {
        my $rv;
        local @jumps   = @j;
        local @indices = @ix;
        {
            $rv = $i->();
            return unless $rv;
            my $key = join ',', sort { $a <=> $b } @$rv;
            redo if $c{$key}++;
        }
        $rv = [ @$translator[@$rv] ];
        if ( $opts->{sorted} ) {
            $rv = [ sort @$rv ];
        }
        $rv;
    };
}

# iterator that manages the trie list
sub _iterator {
    my ( $tries, $counts, $opts ) = @_;
    my $total = 0;
    $total += $_ for @$counts[@indices];
    my @t = @$tries;
    my $i;
    my $s = sub {
        my $rv;
        {
            unless ($i) {
                if (@t) {
                    my $pair = shift @t;
                    local ( $trie, $known ) = @$pair;
                    redo unless _all_known($counts);
                    my $words = _words_in( $counts, $total );
                    redo unless _worth_pursuing( $counts, $words );
                    $i = _sub_iterator( $tries, $words, $opts );
                }
                else {
                    return $rv;
                }
            }
            $rv = $i->();
            unless ($rv) {
                undef $i;
                redo;
            }
        }
        $rv;
    };
    $s;
}

# iterator that actually walks tries looking for anagrams
sub _sub_iterator {
    my ( $tries, $words, $opts ) = @_;
    my @pairs = @$words;
    return sub {
        {
            return unless @pairs;
            if ( $opts->{random} ) {
                my $i = int rand scalar @pairs;
                if ($i) {
                    my $p = $pairs[0];
                    $pairs[0] = $pairs[$i];
                    $pairs[$i] = $p;
                }
            }
            my ( $w, $s ) = @{ $pairs[0] };
            unless ( ref $s eq 'CODE' ) {
                if ( _any($s) ) {
                    $s = _iterator( $tries, $s, $opts );
                }
                else {
                    my $next = [];
                    $s = sub {
                        my $rv = $next;
                        undef $next;
                        $rv;
                    };
                }
                $pairs[0][1] = $s;
            }
            my $remainder = $s->();
            unless ($remainder) {
                shift @pairs;
                redo;
            }
            return [ $w, @$remainder ];
        }
    };
}

# all character counts decremented
sub _worth_pursuing {
    my ( $counts, $words ) = @_;

    my $c;

    # if any letter count didn't change, there's no hope
  OUTER: for my $i (@indices) {
        next unless $c = $counts->[$i];
        for (@$words) {
            next OUTER if $_->[1][$i] < $c;
        }
        return;
    }
    return 1;
}

sub _indices {
    my $counts = shift;
    my @indices;
    for my $i ( 0 .. $#$counts ) {
        push @indices, $i if $counts->[$i];
    }
    return @indices;
}

sub _jumps {
    my $counts = shift;
    my @jumps  = (0) x @$counts;
    my $j      = 0;
    while ( my $n = _next_jump( $counts, $j ) ) {
        $jumps[$j] = $n;
        $j = $n;
    }
    $jumps[-1] = -1;
    return @jumps;
}

sub _next_jump {
    my ( $counts, $j ) = @_;
    for my $i ( $j + 1 .. $#$counts ) {
        return $i if $counts->[$i];
    }
    return;
}

sub _clean {
    $_[0] =~ s/\W+//g;
    $_[0] = lc $_[0];
}

sub _all_known {
    my $counts = shift;
    return if @$counts > @$known;
    for my $i ( 0 .. $#$counts ) {
        return if $counts->[$i] && !$known->[$i];
    }
    return 1;
}


sub key {
    my ( $self, $phrase ) = @_;
    $self->{clean}->($phrase);
    my $offset = $self->{offset};
    my ( @counts, $lowest );
    for my $c ( map { ord($_) - $offset } split //, $phrase ) {
        if ( defined $lowest ) {
            $lowest = $c if $c < $lowest;
        }
        else {
            $lowest = $c;
        }
        $counts[$c]++;
    }
    @counts = @counts[ $lowest .. $#counts ];
    $_ //= '' for @counts;
    my $suffix = join '.', @counts;
    $suffix =~ s/\.(\.+)\./'('.length($1).')'/ge;
    return "$lowest:$suffix";
}


sub lists {
    my $self = shift;
    return scalar @{ $self->{tries} };
}

sub _counts {
    my ( $phrase, $offset ) = @_;
    my @counts;
    for my $c ( map { ord($_) - $offset } split //, $phrase ) {
        $counts[$c]++;
    }
    $_ //= 0 for @counts;
    \@counts;
}

sub _any {
    for ( @{ $_[0] } ) {
        return 1 if $_;
    }
    '';
}

sub _anagramize {
    my $counts = shift;
    my $total  = 0;
    $total += $_ for @$counts[@indices];
    my $key;
    if ( $total <= $limit ) {
        $key = join ',', @$counts[@indices];
        my $cached = $cache{$key};
        return @$cached if $cached;
    }
    my @anagrams;
    my $words = _words_in( $counts, $total );
    if ( _all_touched( $counts, $words ) ) {
        for (@$words) {
            my ( $word, $c ) = @$_;
            if ( _any($c) ) {
                push @anagrams, [ $word, @$_ ] for _anagramize($c);
            }
            else {
                push @anagrams, [$word];
            }
        }
        my %seen;
        @anagrams = map {
            $seen{ join ' ', sort { $a <=> $b } @$_ }++
              ? ()
              : $_
        } @anagrams;
    }
    $cache{$key} = \@anagrams if $key;
    @anagrams;
}

sub _all_touched {
    my ( $counts, $words ) = @_;

    my $c;

    my ( @tallies, @good_indices );
    for (@$words) {
        my $wc = $_->[1];
        for (@indices) {
            next unless $c = $counts->[$_];
            $good_indices[$_] //= $_;
            $tallies[$_]++ if $wc->[$_] < $c;
        }
    }

    # if any letter count didn't change, there's no hope
    return unless @good_indices;
    for (@good_indices) {
        next   unless $_;
        return unless $tallies[$_];
    }

    # find the letter with the fewest possibilities
    my ( $best, $min, $n );
    for (@good_indices) {
        next unless $_;
        $n = $tallies[$_];
        if ( !$best || $n < $min ) {
            $best = $_;
            $min  = $n;
        }
    }

    # we only need consider all the branches which affected a
    # particular letter; we will find all possibilities in their
    # ramifications
    $c = $counts->[$best];
    @$words = grep { $_->[1][$best] < $c } @$words;
    return 1;
}

1;

__END__