Games::Word - utility functions for writing word games

    use Games::Word;
    print "permutation!\n" if is_permutation 'word', 'orwd';
    my $mm_solution = random_string_from "abcdefgh";
    my $mm_guess = <>;
    chomp $mm_guess;
    my $mm_correct_letters = shared_letters $mm_solution, $mm_guess;
    my $mm_correct_positions = shared_letters_by_position $mm_solution,
                                                          $mm_guess;

    perldoc Games::Word

package Games::Word;
our $VERSION = '0.05';


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;

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;