mirror of
https://github.com/pragma-/pbot.git
synced 2024-11-05 19:49:32 +01:00
Update WordMorph
This commit is contained in:
parent
b9dc225763
commit
0edfee6d15
BIN
data/wordmorph.db
vendored
BIN
data/wordmorph.db
vendored
Binary file not shown.
6
lib/PBot/Plugin/WordMorph.pm
Executable file → Normal file
6
lib/PBot/Plugin/WordMorph.pm
Executable file → Normal 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];
|
||||
|
@ -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
35
misc/wordmorph/wordmorph-mkdb
Executable 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
135
misc/wordmorph/wordmorph-solver
Executable 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";
|
||||
}
|
Loading…
Reference in New Issue
Block a user