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

Я хочу, чтобы Perl (5.8.8) выяснил, какое слово имеет большинство букв вместе с другими словами в массиве - но только буквы, находящиеся в одном и том же месте. (И желательно без использования libs.)

Возьмите этот список слов в качестве примера:

  • BAKER
  • Мототехника
  • BALER
  • CARER
  • RUFFR

Ее БАЛЕР - это слово, которое имеет большинство общих черт с другими. Он соответствует BAxER в BAKER, xALER в SALER, xAxER в CARER и xxxxR в RUFFR.

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

То, что я пробовал до сих пор

На данный момент на самом деле нет большого количества script:

use strict;
use warnings; 
my @wordlist = qw(BAKER SALER MALER BARER RUFFR);
foreach my $word (@wordlist) {
    my @letters = split(//, $word);
    # now trip trough each iteration and work magic...
}

Если комментарий есть, я пробовал несколько видов кода, тяжелый с for-loops и ++ varables. До сих пор ни одна из моих попыток не сделала то, что мне нужно.

Итак, чтобы лучше объяснить: мне нужно проверить слово в слово против списка, для каждого буквенного положения, найти слово, которое имеет большинство букв вместе с остальными в списке, в этом письме положение.

Один из возможных способов может заключаться в том, чтобы сначала проверить, какое слово (и) имеет наибольшее общее значение в позиции буквы 0, затем проверить буквенное положение 1 и т.д., пока не найдете слово, что в сумме имеет наибольшее количество букв вместе с другими словами в списке. Затем я хотел бы распечатать список как матрицу с оценками для каждого буквенного положения плюс общий балл для каждого слова, в отличие от того, что предлагает DavidO.

В итоге вы получите матрицу для каждого слова, с оценкой для каждой позиции буквы и суммарным счетом для каждого слова в матрице.

Назначение программы

Хе-хе, я мог бы также сказать это: программа предназначена для взлома терминалов в игре Fallout 3.: D Я думаю, что это отличный способ изучить Perl, а также весело играть в игры.

Вот один из учебников по хакерству терминала Fallout 3, который я использовал для исследования: FALLOUT 3: FAQ по взлому v1.2, вы уже сделали программу для сокращения списка слов, например:

#!/usr/bin/perl
# See if one word has equal letters as the other, and how many of them are equal
use strict;
use warnings; 

my $checkword = "APPRECIATION"; # the word to be checked
my $match = 4; # equal to the match you got from testing your checkword
my @checkletters = split(//, $checkword); #/

my @wordlist = qw(
    PARTNERSHIPS
    REPRIMANDING
    CIVILIZATION
    APPRECIATION
    CONVERSATION
    CIRCUMSTANCE
    PURIFICATION
    SECLUSIONIST
    CONSTRUCTION
    DISAPPEARING
    TRANSMISSION
    APPREHENSIVE
    ENCOUNTERING
);

print "$checkword has $match letters in common with:\n";

foreach my $word (@wordlist) {
    next if $word eq $checkword;
    my @letters = split(//, $word);
    my $length = @letters; # determine length of array (how many letters to check)

    my $eq_letters = 0; # reset to 0 for every new word to be tested
    for (my $i = 0; $i < $length; $i++) {
        if ($letters[$i] eq $checkletters[$i]) {
            $eq_letters++;
        }
    }
    if ($eq_letters == $match) {
        print "$word\n";
    }
}
# Now to make a script on to find the best word to check in the first place...

Этот script будет давать CONSTRUCTION и TRANSMISSION как результат, так же как и в FAQ игры. Однако трюк с исходным вопросом (и то, чему я не смог выяснить сам по себе), заключается в том, как найти лучшее слово, чтобы попробовать в первую очередь, т.е. APPRECIATION.

ОК, я теперь предоставил свое собственное решение на основе вашей помощи и рассмотрел эту тему закрытой. Многие, многие благодаря всем вкладчикам. Вы очень помогли, и по дороге я тоже многому научился.: D

+6
10 июл. '11 в 5:04
источник поделиться
8 ответов

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

$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'} })
);
+5
10 июл. '11 в 5:19
источник

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

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

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, каждый со счетом из четырех позиционных матчей. То есть, кумулятивные моменты, когда один столбец один, строка один соответствует столбцу одна строка два, три и четыре и т.д. Для последующих столбцов. Возможно, он сможет быть оптимизирован и переформулирован, чтобы быть короче, но я старался, чтобы логика довольно легко читалась. Наслаждайтесь!

UPDATE/EDIT Я подумал об этом и понял, что, хотя мой существующий метод делает именно то, что ваш первоначальный вопрос запрашивал, он сделал это в 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% быстрее исходного метода. Больше удовольствия за меньшее время!

+7
10 июл. '11 в 5:32
источник

Здесь полный script. Он использует ту же идею, что и yht (хотя я имел ее независимо). Используйте побитовое xor для объединения строк, а затем подсчитывайте количество 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);
+4
10 июл. '11 в 5:29
источник

Не трогайте 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 циклов, который подходит для большинства приложений.

+2
10 июл. '11 в 5:15
источник

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

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

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;
}
+1
10 июл. '11 в 12:26
источник

Вот моя попытка ответить. Это также позволит вам увидеть каждый индивидуальный матч, если вам это нужно. (т.е. BALER соответствует 4 символам в BAKER). EDIT: теперь он ловит все совпадения, если есть связь между словами (я добавил "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 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} )
}

Результат просто: CAKER BALER и BAKER.

Хеш %wordcomparison выглядит следующим образом:

'SALER'
        {
          'RUFFR' => 1,
          'BALER' => 4,
          'BAKER' => 3,
          'total' => 11,
          'CARER' => 3
        };
+1
10 июл. '11 в 9:09
источник

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

#!/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";
}

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

BAKER: 11
SALER: 11
BALER: 12 <- best
CARER: 10
RUFFR: 4
0
16 июл. '11 в 0:17
источник

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

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

(?:(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 trick будет быстрым, но предполагает много о диапазоне символов, с которыми вы можете столкнуться. Существует много способов, с помощью которых utf-8 будет ломаться с этим случаем.

0
10 июл. '11 в 5:38
источник

Посмотрите другие вопросы по меткам или Задайте вопрос