File Coverage

blib/lib/Games/Word.pm

Criterion	Covered	Total	%
statement	89	89	100.0
branch	23	24	95.8
condition	16	18	88.8
subroutine	18	18	100.0
pod	10	10	100.0
total	156	159	98.1

package Games::Word;
BEGIN {
  $Games::Word::AUTHORITY = 'cpan:DOY';
}
{
  $Games::Word::VERSION = '0.06';
}
use strict;
use warnings;
use base 'Exporter';
our @EXPORT_OK = qw/random_permutation is_permutation all_permutations
                    shared_letters shared_letters_by_position
                    random_string_from
                    is_substring all_substrings
                    is_subpermutation all_subpermutations/;

use Math::Combinatorics qw/factorial/;
use Test::Deep::NoTest;
# ABSTRACT: utility functions for writing word games


sub random_permutation {
    my $word = shift;

    return '' if $word eq '';

    my $letter = substr $word, int(rand length $word), 1, '';

    return $letter . random_permutation($word);
}


sub is_permutation {
    my @word_letters = split //, shift;
    my @perm_letters = split //, shift;

    return eq_deeply(\@word_letters, bag(@perm_letters));
}

sub _permutation {
    my $word = shift;
    my $perm_index = shift;

    return '' if $word eq '';

    my $len = length $word;
    die "invalid permutation index" if $perm_index >= factorial($len) ||
                                       $perm_index < 0;

    use integer;

    my $current_index = $perm_index / factorial($len - 1);
    my $rest = $perm_index % factorial($len - 1);

    my $first_letter = substr($word, $current_index, 1);
    substr($word, $current_index, 1) = '';

    return $first_letter . _permutation($word, $rest);
}


sub all_permutations {
    my $word = shift;

    my @ret = ();
    push @ret, _permutation($word, $_)
        for 0..(factorial(length $word) - 1);

    return @ret;
}


sub shared_letters {
    my @a = sort split //, shift;
    my @b = sort split //, shift;

    my @letters = ();
    my ($a, $b) = (shift @a, shift @b);
    while (defined $a && defined $b) {
        if ($a eq $b) {
            push @letters, $a;
            ($a, $b) = (shift @a, shift @b);
        }
        elsif ($a lt $b) {
            $a = shift @a;
        }
        else {
            $b = shift @b;
        }
    }

    return @letters;
}


sub shared_letters_by_position {
    my @a = split //, shift;
    my @b = split //, shift;

    my @letters = ();
    while (my ($a, $b) = (shift @a, shift @b)) {
        last unless (defined $a || defined $b);
        if (defined $a && defined $b && $a eq $b) {
            push @letters, $a;
        }
        else {
            push @letters, undef;
        }
    }

    return wantarray ? @letters : grep { defined } @letters;
}


sub random_string_from {
    my ($letters, $length) = @_;

    die "invalid letter list" if length $letters < 1 && $length > 0;
    my @letters = split //, $letters;
    my $ret = '';
    $ret .= $letters[int rand @letters] for 1..$length;

    return $ret;
}


sub is_substring {
    my ($substring, $string) = @_;

    return 1 if $substring eq '';
    return 0 if $string eq '';
    my $re = join('?', map { quotemeta } split(//, $string)) . '?';
    return $substring =~ /^$re$/;
}


sub all_substrings {
    my $string = shift;

    return ('') if $string eq '';

    my @substrings = ($string);
    my $before = '';
    my $current = substr $string, 0, 1, '';
    while ($current) {
        @substrings = (@substrings,
                       map { $before . $_ } all_substrings($string));
        $before .= $current;
        $current = substr $string, 0, 1, '';
    }

    return @substrings;
}


sub is_subpermutation {
    my @subword = split //, shift;
    my @word = split //, shift;

    return eq_deeply(\@subword, subbagof(@word));
}


sub all_subpermutations {
    return map { all_permutations $_ } all_substrings shift;
}


1;

__END__