diff --git a/data/wordmorph.db b/data/wordmorph.db index 23967064..7bf37bb2 100644 Binary files a/data/wordmorph.db and b/data/wordmorph.db differ diff --git a/lib/PBot/Plugin/WordMorph.pm b/lib/PBot/Plugin/WordMorph.pm old mode 100755 new mode 100644 index 8b50201c..40c55813 --- a/lib/PBot/Plugin/WordMorph.pm +++ b/lib/PBot/Plugin/WordMorph.pm @@ -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]; diff --git a/lib/PBot/VERSION.pm b/lib/PBot/VERSION.pm index 51789b24..aef3a508 100644 --- a/lib/PBot/VERSION.pm +++ b/lib/PBot/VERSION.pm @@ -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 {} diff --git a/misc/wordmorph/wordmorph-mkdb b/misc/wordmorph/wordmorph-mkdb new file mode 100755 index 00000000..bba4b181 --- /dev/null +++ b/misc/wordmorph/wordmorph-mkdb @@ -0,0 +1,35 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Storable; +use Text::Levenshtein::XS 'distance'; + +die "usage: $0 \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'; diff --git a/misc/wordmorph/wordmorph-solver b/misc/wordmorph/wordmorph-solver new file mode 100755 index 00000000..976f3fc6 --- /dev/null +++ b/misc/wordmorph/wordmorph-solver @@ -0,0 +1,135 @@ +#!/usr/bin/perl +#ver 2.00 + +use warnings; +use strict; + +use Storable; +use Text::Levenshtein::XS 'distance'; + +die < + +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"; +}