Найдите слово с наибольшим количеством общих букв с другими словами

В качестве отправной точки вы можете эффективно проверить, сколько букв они имеют вместе:

$count = ($word1 ^ $word2) =~ y/\0//;

Но это полезно только в том случае, если вы перебираете все возможные пары слов, что в данном случае не обязательно:

use strict;
use warnings;
my @words = qw/
    BAKER
    SALER
    BALER
    CARER
    RUFFR
/;

# you want a hash to indicate which letters are present how many times in each position:

my %count;
for my $word (@words) {
    my @letters = split //, $word;
    $count{$_}{ $letters[$_] }++ for 0..$#letters;
}

# then for any given word, you get the count for each of its letters minus one (because the word itself is included in the count), and see if it is a maximum (so far) for any position or for the total:

my %max_common_letters_count;
my %max_common_letters_words;
for my $word (@words) {
    my @letters = split //, $word;
    my $total;
    for my $position (0..$#letters, 'total') {
        my $count;
        if ( $position eq 'total' ) {
            $count = $total;
        }
        else {
            $count = $count{$position}{ $letters[$position] } - 1;
            $total += $count;
        }
        if ( ! $max_common_letters_count{$position} || $count >= $max_common_letters_count{$position} ) {
            if ( $max_common_letters_count{$position} && $count == $max_common_letters_count{$position} ) {
                push @{ $max_common_letters_words{$position} }, $word;
            }
            else {
                $max_common_letters_count{$position} = $count;
                $max_common_letters_words{$position} = [ $word ];
            }
        }
    }
}

# then show the maximum words for each position and in total: 

for my $position ( sort { $a <=> $b } grep $_ ne 'total', keys %max_common_letters_count ) {
    printf( "Position %s had a maximum of common letters of %s in words: %s\n",
        $position,
        $max_common_letters_count{$position},
        join(', ', @{ $max_common_letters_words{$position} })
    );
}
printf( "The maximum total common letters was %s in words(s): %s\n",
    $max_common_letters_count{'total'},
    join(', ', @{ $max_common_letters_words{'total'} })
);

Вот один из способов. Перечитав вашу спецификацию пару раз, я думаю, что это то, что вы ищете.

Стоит отметить, что возможно будет более одного слова с одинаковым наивысшим баллом. Из вашего списка есть только один победитель, но возможно, что в более длинных списках будет несколько одинаково выигрышных слов. Это решение имеет дело с этим. Кроме того, насколько я понимаю, совпадения букв учитываются только в том случае, если они встречаются в одном и том же столбце для каждого слова. Если это так, вот рабочее решение:

use 5.012;
use strict;
use warnings;
use List::Util 'max';

my @words = qw/
    BAKER
    SALER
    BALER
    CARER
    RUFFR
/;

my @scores;
foreach my $word ( @words ) {
    my $score;
    foreach my $comp_word ( @words ) {
        next if $comp_word eq $word;
        foreach my $pos ( 0 .. ( length $word ) - 1 ) {
            $score++ if substr( $word, $pos, 1 ) eq substr( $comp_word, $pos, 1);
        }
    }
    push @scores, $score;
}
my $max = max( @scores );
my ( @max_ixs ) = grep { $scores[$_] == $max } 0 .. $#scores;

say "Words with most matches:";
say for @words[@max_ixs];

Это решение подсчитывает, сколько раз в столбце букв буквы каждого слова совпадают с другими словами. Так, например:

Words:     Scores:       Because:
ABC        1, 2, 1 = 4   A matched once,  B matched twice, C matched once.
ABD        1, 2, 1 = 4   A matched once,  B matched twice, D matched once.
CBD        0, 2, 1 = 3   C never matched, B matched twice, D matched once.
BAC        0, 0, 1 = 1   B never matched, A never matched, C matched once.

Это дает вам победителей ABC и ABD, каждый из которых набрал четыре позиционных матча. То есть совокупное количество раз, когда первый столбец, первая строка совпали со столбцом, первой строкой, второй, третьей и четвертой, и так далее для последующих столбцов. Возможно, его можно будет дополнительно оптимизировать и переформулировать, чтобы он был короче, но я старался, чтобы логика была довольно легко читаемой. Наслаждаться!

ОБНОВЛЕНИЕ / РЕДАКТИРОВАТЬ Я подумал об этом и понял, что, хотя мой существующий метод делает именно то, что требовал ваш первоначальный вопрос, он сделал это за время O (n ^ 2), что сравнительно медленно. Но если мы используем хеш-ключи для букв каждого столбца (одна буква на ключ) и подсчитываем, сколько раз каждая буква появляется в столбце (в качестве значения хэш-элемента), мы могли бы выполнять наши суммирования за O (1). ) раз, а наш обход списка — за время O(n*c) (где c — количество столбцов, а n — количество слов). Также есть время на настройку (создание хэша). Но у нас все еще есть большое улучшение. Вот новая версия каждой техники, а также сравнение каждой из них.

use strict;
use warnings;
use List::Util qw/ max sum /;
use Benchmark qw/ cmpthese /;

my @words = qw/
    PARTNERSHIPS
    REPRIMANDING
    CIVILIZATION
    APPRECIATION
    CONVERSATION
    CIRCUMSTANCE
    PURIFICATION
    SECLUSIONIST
    CONSTRUCTION
    DISAPPEARING
    TRANSMISSION
    APPREHENSIVE
    ENCOUNTERING
/;


# Just a test run for each solution.
my( $top, $indexes_ref );

($top, $indexes_ref ) = find_top_matches_force( \@words );
print "Testing force method: $top matches.\n";
print "@words[@$indexes_ref]\n";

( $top, $indexes_ref ) = find_top_matches_hash( \@words );
print "Testing hash  method: $top matches.\n";
print "@words[@$indexes_ref]\n";



my $count = 20000;
cmpthese( $count, {
    'Hash'  => sub{ find_top_matches_hash( \@words ); },
    'Force' => sub{ find_top_matches_force( \@words ); },
} );


sub find_top_matches_hash {
    my $words = shift;
    my @scores;
    my $columns;
    my $max_col = max( map { length $_ } @{$words} ) - 1;
    foreach my $col_idx ( 0 .. $max_col ) {
        $columns->[$col_idx]{ substr $_, $col_idx, 1 }++ 
            for @{$words};
    }
    foreach my $word ( @{$words} ) {
        my $score = sum( 
            map{ 
                $columns->[$_]{ substr $word, $_, 1 } - 1
            } 0 .. $max_col
        );
        push @scores, $score;
    }
    my $max = max( @scores );
    my ( @max_ixs ) = grep { $scores[$_] == $max } 0 .. $#scores;
    return(  $max, \@max_ixs );
}


sub find_top_matches_force {
    my $words = shift;
    my @scores;
    foreach my $word ( @{$words} ) {
        my $score;
        foreach my $comp_word ( @{$words} ) {
            next if $comp_word eq $word;
            foreach my $pos ( 0 .. ( length $word ) - 1 ) {
                $score++ if 
                    substr( $word, $pos, 1 ) eq substr( $comp_word, $pos, 1);
            }
        }
        push @scores, $score;
    }
    my $max = max( @scores );
    my ( @max_ixs ) = grep { $scores[$_] == $max } 0 .. $#scores;
    return( $max, \@max_ixs );
}

Результат:

Testing force method: 39 matches.
APPRECIATION
Testing hash  method: 39 matches.
APPRECIATION
        Rate Force  Hash
Force 2358/s    --  -74%
Hash  9132/s  287%    --

Я понимаю, что ваша первоначальная спецификация изменилась после того, как вы увидели некоторые из других предоставленных опций, и в какой-то степени это своего рода инновация, но головоломка все еще была жива в моей голове. Как видите, мой метод хеширования на 287% быстрее исходного метода. Больше удовольствия за меньшее время!

Вот полный сценарий. Он использует ту же идею, которую упомянул ysth (хотя она была у меня независимо). Используйте побитовое исключающее ИЛИ, чтобы объединить строки, а затем подсчитайте количество NUL в результате. Пока ваши строки являются ASCII, это скажет вам, сколько совпадающих букв было. (Это сравнение чувствительно к регистру, и я не уверен, что произойдет, если строки будут UTF-8. Вероятно, ничего хорошего.)

use strict;
use warnings;
use 5.010;

use List::Util qw(max);

sub findMatches
{
  my ($words) = @_;

  # Compare each word to every other word:
  my @matches = (0) x @$words;

  for my $i (0 .. $#$words-1) {
    for my $j ($i+1 .. $#$words) {
      my $m = ($words->[$i] ^ $words->[$j]) =~ tr/\0//;

      $matches[$i] += $m;
      $matches[$j] += $m;
    }
  }

  # Find how many matches in the best word:
  my $max = max(@matches);

  # Find the words with that many matches:
  my @wanted = grep { $matches[$_] == $max } 0 .. $#matches;

  wantarray ? @$words[@wanted] : $words->[$wanted[0]];
} # end findMatches

my @words = qw(
    BAKER
    SALER
    BALER
    CARER
    RUFFR
);

say for findMatches(\@words);

Некоторое время не касался perl, так что это псевдокод. Это не самый быстрый алгоритм, но он отлично работает для небольшого количества слов.

totals = new map #e.g. an object to map :key => :value

for each word a
  for each word b
    next if a equals b

    totals[a] = 0
    for i from 1 to a.length
      if a[i] == b[i]
        totals[a] += 1
      end
    end
  end
end

return totals.sort_by_key.last

Извините за отсутствие Perl, но если вы закодируете это на Perl, это должно работать как шарм.

Небольшое примечание о времени выполнения: это будет выполняться за время number_of_words^2 * length_of_words, поэтому для списка из 100 слов, каждое из которых имеет длину 10 символов, это будет выполняться за 100 000 циклов, что достаточно. для большинства приложений.

Вот версия, основанная на перестановке слов для подсчета одинаковых символов. Я использовал слова из вашего оригинального сравнения, а не код.

Это должно работать со словами любой длины и списком любой длины. Выход:

Word    score
----    -----
BALER   12
SALER   11
BAKER   11
CARER   10
RUFFR   4

Код:

use warnings;
use strict;

my @w = qw(BAKER SALER BALER CARER RUFFR);
my @tword = t_word(@w);

my @score;
push @score, str_count($_) for @tword;
@score = t_score(@score);

my %total;

for (0 .. $#w) {
    $total{$w[$_]} = $score[$_];
}

print "Word\tscore\n";
print "----\t-----\n";
print "$_\t$total{$_}\n" for (sort { $total{$b} <=> $total{$a} } keys %total);

# transpose the words
sub t_word {
    my @w = @_;
    my @tword;
    for my $word (@w) {
        my $i = 0;
        while ($word =~ s/(.)//) {
            $tword[$i++] .= $1;
        }
    }
    return @tword;
}

# turn each character into a count
sub str_count {
    my $str = uc(shift);
    while ( $str =~ /([A-Z])/ ) {
        my $chr = $1;
        my $num = () = $str =~ /$chr/g;
        $num--;
        $str =~ s/$chr/$num /g;
    }
    return $str;
}

# sum up the character counts
# while reversing the transpose
sub t_score {
    my @count = @_;
    my @score;
    for my $num (@count) {
        my $i = 0;
        while( $num =~ s/(\d+) //) {
            $score[$i++] += $1;
        }
    }
    return @score;
}

Вот моя попытка ответить. Это также позволит вам увидеть каждый отдельный матч, если вам это нужно. (т.е. BALER соответствует 4 символам в BAKER). РЕДАКТИРОВАТЬ: теперь он перехватывает все совпадения, если между словами есть связь (я добавил "CAKER" в список для проверки).

#! usr/bin/perl

use strict;
use warnings;

my @wordlist = qw( BAKER SALER BALER CARER RUFFR CAKER);

my %wordcomparison;

#foreach word, break it into letters, then compare it against all other words
#break all other words into letters and loop through the letters (both words have same amount), adding to the count of matched characters each time there's a match
foreach my $word (@wordlist) {
    my @letters = split(//, $word);
    foreach my $otherword (@wordlist) {
        my $count;
        next if $otherword eq $word;
        my @otherwordletters = split (//, $otherword);
        foreach my $i (0..$#letters) {
            $count++ if ( $letters[$i] eq $otherwordletters[$i] );
        }
        $wordcomparison{"$word"}{"$otherword"} = $count;
    }
}

# sort (unnecessary) and loop through the keys of the hash (words in your list)
# foreach key, loop through the other words it compares with
#Add a new key: total, and sum up all the matched characters.
foreach my $word (sort keys %wordcomparison) {
    foreach ( sort keys %{ $wordcomparison{$word} }) {
        $wordcomparison{$word}{total} += $wordcomparison{$word}{$_};
    }
}

#Want $word with highest total

my @max_match = (sort { $wordcomparison{$b}{total} <=> $wordcomparison{$a}{total} } keys %wordcomparison );

#This is to get all if there is a tie:
my $maximum = $max_match[0];
foreach (@max_match) {
print "$_\n" if ($wordcomparison{$_}{total} >= $wordcomparison{$maximum}{total} )
}

Результат прост: ПЕЧИК БАЛЕР и ПЕКАРЬ.

Хэш %wordcomparison выглядит так:

'SALER'
        {
          'RUFFR' => 1,
          'BALER' => 4,
          'BAKER' => 3,
          'total' => 11,
          'CARER' => 3
        };

Вы можете сделать это, используя грязный трюк с регулярными выражениями для выполнения кода, если буква совпадает на своем месте, но не иначе, к счастью, довольно легко создавать регулярные выражения по ходу:

Пример регулярного выражения:

(?:(C(?{ $c++ }))|.)(?:(A(?{ $c++ }))|.)(?:(R(?{ $c++ }))|.)(?:(E(?{ $c++ }))|.)(?:(R(?{ $c++ }))|.)

Это может быть или не быть быстрым.

use 5.12.0;
use warnings;
use re 'eval';

my @words = qw(BAKER SALER BALER CARER RUFFR);

my ($best, $count) = ('', 0);
foreach my $word (@words) {
    our $c = 0;
    foreach my $candidate (@words) {
    next if $word eq $candidate;

    my $regex_str = join('', map {"(?:($_(?{ \$c++ }))|.)"} split '', $word);
    my $regex = qr/^$regex_str$/;

    $candidate =~ $regex or die "did not match!";
    }
    say "$word $c";
    if ($c > $count) {
    $best = $word;
    $count = $c;
    }
}

say "Matching: first best: $best";

Использование трюка xor будет быстрым, но предполагает многое в отношении диапазона символов, с которыми вы можете столкнуться. Есть много способов, которыми utf-8 сломается в этом случае.

Большое спасибо всем участникам! Вы, безусловно, показали мне, что мне еще многому нужно научиться, но вы также очень помогли мне в разработке моего собственного ответа. Я просто размещаю его здесь для справки и возможных отзывов, поскольку, вероятно, есть лучшие способы сделать это. Для меня это был самый простой и прямой подход, который я мог найти самостоятельно. Наслаждаться! :)

#!/usr/bin/perl
use strict;
use warnings; 

# a list of words for testing
my @list = qw( 
BAKER
SALER
BALER
CARER
RUFFR
);

# populate two dimensional array with the list, 
# so we can compare each letter with the other letters on the same row more easily 
my $list_length = @list;
my @words;

for (my $i = 0; $i < $list_length; $i++) {
    my @letters = split(//, $list[$i]);
    my $letters_length = @letters;
    for (my $j = 0; $j < $letters_length; $j++) {
        $words[$i][$j] = $letters[$j];
    }
}
# this gives a two-dimensionla array:
#
# @words = (    ["B", "A", "K", "E", "R"],
#               ["S", "A", "L", "E", "R"],
#               ["B", "A", "L", "E", "R"],
#               ["C", "A", "R", "E", "R"],
#               ["R", "U", "F", "F", "R"],
# );

# now, on to find the word with most letters in common with the other on the same row

# add up the score for each letter in each word
my $word_length = @words;
my @letter_score;
for my $i (0 .. $#words) {
    for my $j (0 .. $#{$words[$i]}) {
        for (my $k = 0; $k < $word_length; $k++) {
            if ($words[$i][$j] eq $words[$k][$j]) {
                $letter_score[$i][$j] += 1; 
            }
        }
        # we only want to add in matches outside the one we're testing, therefore
        $letter_score[$i][$j] -= 1;
    }
}

# sum each score up
my @scores;
for my $i (0 .. $#letter_score ) {
    for my $j (0 .. $#{$letter_score[$i]}) {
        $scores[$i] += $letter_score[$i][$j];
    }
}

# find the highest score
my $max = $scores[0];
foreach my $i (@scores[1 .. $#scores]) {
    if ($i > $max) {
        $max = $i;
    }
}

# and print it all out :D
for my $i (0 .. $#letter_score ) {
    print "$list[$i]: $scores[$i]";
    if ($scores[$i] == $max) {
        print " <- best";
    }   
    print "\n";
}

При запуске скрипт выдает следующее:

BAKER: 11
SALER: 11
BALER: 12 <- best
CARER: 10
RUFFR: 4