3
0
mirror of https://github.com/pragma-/pbot.git synced 2024-11-05 19:49:32 +01:00

Update WordMorph

This commit is contained in:
Pragmatic Software 2022-08-26 00:33:41 -07:00
parent b9dc225763
commit 0edfee6d15
5 changed files with 175 additions and 5 deletions

BIN
data/wordmorph.db vendored

Binary file not shown.

6
lib/PBot/Plugin/WordMorph.pm Executable file → Normal file
View File

@ -134,8 +134,8 @@ sub wordmorph {
}
if (defined $args[1]) {
if ($args[1] !~ m/^[0-9]+$/ || $args[1] < 3 || $args[1] > 8) {
return "Invalid word length `$args[1]`; must be integer >= 3 and <= 8."
if ($args[1] !~ m/^[0-9]+$/ || $args[1] < 3 || $args[1] > 7) {
return "Invalid word length `$args[1]`; must be integer >= 3 and <= 7."
}
$length = $args[1];
@ -271,7 +271,7 @@ sub set_up_new_morph {
sub make_morph_by_steps {
my ($self, $db, $steps, $length) = @_;
$length //= int(rand(3)) + 4;
$length //= int(rand(4)) + 4;
my @words = keys %{$db->{$length}};
my $word = $words[rand $#words];

View File

@ -25,8 +25,8 @@ use PBot::Imports;
# These are set by the /misc/update_version script
use constant {
BUILD_NAME => "PBot",
BUILD_REVISION => 4574,
BUILD_DATE => "2022-08-24",
BUILD_REVISION => 4575,
BUILD_DATE => "2022-08-26",
};
sub initialize {}

35
misc/wordmorph/wordmorph-mkdb Executable file
View File

@ -0,0 +1,35 @@
#!/usr/bin/perl
use warnings;
use strict;
use Storable;
use Text::Levenshtein::XS 'distance';
die "usage: $0 <wordlist file>\n" unless @ARGV == 1;
#thanks to Limbic~Region, http://perlmonks.org/index.pl?node_id=180961
open (my $wordlist, '<', $ARGV[0]) or die "Unable to open `$ARGV[0]` for reading: $!\n";
my ($db, %data);
while (<$wordlist>) {
chomp;
next if $_ !~ /^[a-z]{3,7}$/;
push @{$data{length()}}, $_;
}
for my $len (keys %data) {
my $end = $#{$data{$len}};
for my $i (0 .. $end - 1) {
my $word = $data{$len}[$i];
for my $j ($i + 1 .. $end) {
my $test = $data{$len}[$j];
if (distance($word, $test) == 1) {
push @{$db->{$len}{$word}}, $test;
push @{$db->{$len}{$test}}, $word;
}
}
}
}
store $db, 'wordmorph.db';

135
misc/wordmorph/wordmorph-solver Executable file
View File

@ -0,0 +1,135 @@
#!/usr/bin/perl
#ver 2.00
use warnings;
use strict;
use Storable;
use Text::Levenshtein::XS 'distance';
die <<HELP unless @ARGV == 2;
usage: $0 <word1> <word2>
The program finds a way from one word to other, like this:
% $0 love shot
love-lose-lost-loot-soot-shot
HELP
my ($left, $right) = @ARGV[0,1];
for ($left, $right) {
$_ = lc;
}
die "the length of given words is not equal!\n" if length($left) != length $right;
my $db = -e 'wordmorph.db' ? retrieve('wordmorph.db') : die "No database available\n";
my $len = length $left;
foreach my $word ($left, $right) {
if (!$db->{$len}{$word}) {
foreach my $test (keys %{$db->{$len}}) {
if (distance($word, $test) == 1) {
push @{$db->{$len}{$word}}, $test;
push @{$db->{$len}{$test}}, $word;
}
}
}
}
my $list = $db->{length($left)};
eval {
printway([transform($left, $right, $list)]);
1;
} or print $@;
sub transform {
my $left = shift;
my $right = shift;
my $list = shift;
my (@left, %left, @right, %right); # @left and @right- arrays containing word relation trees: ([foo], [0, foe], [0, fou], [0, 1, fie] ...)
# %left and %right - indices containing word offsets in arrays @left and @right
$left[0] = [$left];
$right[0] = [$right];
$left{$left} = 0;
$right{$right} = 0;
my $leftstart = 0;
my $rightstart = 0;
my @way;
my (%leftstarts, %rightstarts);
SEARCH:
for (;;) {
my @left_ids = $leftstart..$#left; # choose array of indices of new words
$leftstart = $#left;
die "Cannot solve! Bad word '$left' :(\n" if $leftstarts{$leftstart}++ >2; # finish search if the way could not be found
for my $id (@left_ids) { # come through all new words
my @prefix = @{$left[$id]};
my $searched = pop @prefix;
push @prefix, $id;
foreach my $word (@{$list->{$searched}}) {
next if $left{$word}; # skip words which are already in the tree
push @left, [@prefix, $word];
$left{$word} = $#left; # add new word to array and index
#print join " ", @{$left[-1]}, "\n"; #debugging
if ( defined(my $r_id = $right{$word}) ) { # and check if the word appears in right index. if yes...
my @end = reverse(print_rel($r_id, \@right));
shift @end;
@way = (print_rel($#left, \@left), @end); # build the way between the words
last SEARCH; # and finish the search
}
}
}
my @right_ids = $rightstart..$#right; # all the same :) the tree is build from both ends to speed up the process
$rightstart = $#right;
die "Cannot solve! Bad word '$right' :(\n" if $rightstarts{$rightstart}++ > 2;
for my $id (@right_ids) { # build right relational table
my @prefix = @{$right[$id]};
my $searched = pop @prefix;
push @prefix, $id;
foreach my $word (@{$list->{$searched}}) {
next if $right{$word};
push @right, [@prefix, $word];
$right{$word} = $#right;
# print join " ", @{$right[-1]}, "\n"; #debugging
if ( defined(my $l_id = $left{$word}) ) {
my @end = reverse print_rel($#right, \@right);
shift @end;
@way = (print_rel($l_id, \@left), @end);
last SEARCH;
}
}
}
}
return @way;
}
sub print_rel {
my $id = shift;
my $ary = shift;
my @line;
my @rel = @{$ary->[$id]};
push @line, (pop @rel);
foreach my $ref_id (reverse @rel) {
unshift @line, $ary->[$ref_id]->[-1];
}
return wantarray ? @line : join "\n", @line, "";
}
sub printway {
my @way = @{+shift};
print join "-", @way;
print "\n";
}