Update WordMorph

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];

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 {}

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 <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';

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 <<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";
+}