perl - qué - Encuentra la palabra con la mayoría de las letras en común con otras palabras

que es la linguistica en ingles

Question

Quiero que Perl (5.8.8) descubra qué palabra tiene más letras en común con las otras palabras en una matriz, pero solo letras que están en el mismo lugar. (Y preferiblemente sin usar libs)

Tome esta lista de palabras como un ejemplo:

• PANADERO
• SALER
• EMBALADORA
• CUIDADOR
• RUFFR

Su BALER es la palabra que tiene más letras en común con las demás. Concuerda con BAxER en BAKER, xALER en SALER, xAxER en CARER y xxxxR en RUFFR.

Quiero que Perl encuentre esta palabra para mí en una lista arbitraria de palabras con la misma longitud y caso. Parece que he golpeado la pared aquí, ¡así que la ayuda es muy apreciada!

Lo que he intentado hasta ahora

Realmente no tengo mucho guión en este momento:

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

Donde está el comentario, he intentado varios tipos de código, pesado con for-loops y ++ varables. Hasta ahora, ninguno de mis intentos ha hecho lo que necesito que haga.

Entonces, para explicar mejor: Lo que necesito es probar palabra por palabra en la lista, para cada posición de letra, para encontrar la palabra que tiene más letras en común con las demás en la lista, en la posición de esa letra.

Una forma posible podría ser primero verificar qué palabra (s) tiene más en común en la posición de la letra 0, luego probar la posición de la letra 1, y así sucesivamente, hasta encontrar la palabra que en suma tiene más letras en común con las otras palabras en la lista. Luego me gustaría imprimir la lista como una matriz con puntajes para cada posición de letra más un puntaje total para cada palabra, no muy diferente de lo que sugiere DavidO.

En realidad, lo que terminaría con es una matriz para cada palabra, con el puntaje para cada posición de letra, y el puntaje total de la suma de cada palabra en la matriz.

Propósito del programa

Hehe, mejor diré: el programa es para hackear terminales en el juego Fallout 3.: D Mi pensamiento es que es una excelente forma de aprender Perl mientras disfrutas de los juegos divertidos.

Este es uno de los tutoriales de hacking de terminales de Fallout 3 que he usado para la investigación: FALLOUT 3: Hacking FAQ v1.2 , y ya he creado un programa para acortar la lista de palabras, como esta:

#!/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...

Este script arrojará CONSTRUCTION y TRANSMISSION como resultado, al igual que en las preguntas frecuentes del juego. Sin embargo, el truco de la pregunta original (y lo que no pude averiguar por mi cuenta) es cómo encontrar la mejor palabra para probar, es decir, APPRECIATION .

De acuerdo, ahora he suministrado mi propia solución en función de su ayuda, y considero este hilo cerrado. Muchas, muchas gracias a todos los contribuyentes. Has ayudado tremendamente, y en el camino también he aprendido mucho. :RE

Answer 1

Aquí está mi intento de respuesta. Esto también le permitirá ver cada coincidencia individual si la necesita. (es decir, BALER coincide con 4 caracteres en BAKER). EDITAR : Ahora atrapa todas las coincidencias si hay un empate entre las palabras (agregué "CAKER" a la lista para probar).

#! 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} )
}

La salida es simplemente: CAKER BALER y BAKER.

El hash %wordcomparison ve así:

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

Answer 2

Aquí hay un guion completo. Utiliza la misma idea que Ysth mencionó (aunque la tuve independientemente). Usa bit_xor para combinar las cadenas y luego cuenta el número de NUL en el resultado. Siempre que tus cadenas sean ASCII, eso te indicará cuántas letras coincidentes hay. (Esa comparación es sensible a mayúsculas y minúsculas, y no estoy seguro de qué pasaría si las cadenas fueran UTF-8. Probablemente nada bueno).

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

Answer 3

Aquí hay una versión que se basa en transponer las palabras para contar los caracteres idénticos. Usé las palabras de tu comparación original, no el código.

Esto debería funcionar con cualquier longitud de palabras y cualquier lista de longitud. La salida es:

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

El código:

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

Answer 4

Como punto de partida, puede verificar de manera eficiente cuántas letras tienen en común con:

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

Pero eso solo es útil si recorre todos los pares de palabras posibles, algo que no es necesario en este caso:

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

Answer 5

No he tocado Perl por un tiempo, así que es un pseudo-código. Este no es el algoritmo más rápido, pero funcionará bien para una pequeña cantidad de palabras.

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

Perdón por la falta de perl, pero si codifica esto en perl, debería funcionar como un amuleto.

Una nota rápida sobre el tiempo de ejecución: esto se ejecutará en el tiempo number_of_words ^ 2 * length_of_words , por lo que en una lista de 100 palabras, cada una de longitud 10 caracteres, esto se ejecutará en 100.000 ciclos, que es adecuado para la mayoría de las aplicaciones.

Answer 6

Puedes hacer esto, usando un truco sucio de expresiones regulares para ejecutar código si una letra coincide en su lugar, pero no de otra manera, afortunadamente es bastante fácil construir las expresiones regulares sobre la marcha:

Una expresión regular de ejemplo es:

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

Esto puede o no ser rápido.

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

Usar el truco xor será rápido pero supone mucho sobre el rango de caracteres que puede encontrar. Hay muchas maneras en que utf-8 romperá con ese caso.

Answer 7

Aquí hay una manera. Después de volver a leer su especificación un par de veces, creo que es lo que está buscando.

Vale la pena mencionar que es posible que haya más de una palabra con un puntaje máximo igual. De su lista solo hay un ganador, pero es posible que en listas más largas, haya varias palabras igualmente ganadoras. Esta solución se ocupa de eso. Además, según tengo entendido, cuentas las correspondencias de letras solo si ocurren en la misma columna por palabra. Si ese es el caso, aquí hay una solución de trabajo:

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

Esta solución cuenta cuántas veces por columna de la letra las letras de cada palabra coinciden con otras palabras. Así por ejemplo:

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.

Eso le da a los ganadores de ABC y ABD, cada uno con una puntuación de cuatro partidos posicionales. Es decir, los tiempos acumulados de la columna uno, fila uno coincidieron con la columna una fila dos, tres y cuatro, y así sucesivamente para las columnas siguientes. Puede optimizarse aún más y volverse a redactar para que sea más corto, pero traté de mantener la lógica bastante fácil de leer. ¡Disfrutar!

ACTUALIZAR / EDITAR Pensé en ello y me di cuenta de que aunque mi método existente hace exactamente lo que tu pregunta original solicitó, lo hizo en O (n ^ 2) tiempo, que es comparativamente lento. Pero si usamos las teclas hash para las letras de cada columna (una letra por tecla) y hacemos un recuento de cuántas veces aparece cada letra en la columna (como el valor del elemento hash), podríamos hacer nuestras sumas en O (1 ) tiempo, y nuestro recorrido de la lista en O (n * c) tiempo (donde c es el número de columnas, yn es el número de palabras). También hay un tiempo de configuración (creación del hash). Pero aún tenemos una gran mejora. Aquí hay una nueva versión de cada técnica, así como una comparación de referencia de cada una.

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 );
}

El resultado es:

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

Me doy cuenta de que su especificación original cambió después de que viera algunas de las otras opciones provistas, y esa es la naturaleza de la innovación hasta cierto punto, pero el acertijo aún estaba vivo en mi mente. Como puede ver, mi método hash es 287% más rápido que el método original. ¡Más diversión en menos tiempo!

Answer 8

¡Muchas gracias a todos los contribuidores! Ciertamente me has demostrado que todavía tengo mucho que aprender, pero también me has ayudado enormemente en la elaboración de mi propia respuesta. Solo lo estoy poniendo aquí para referencia y posible retroalimentación, ya que probablemente haya mejores formas de hacerlo. Para mí, este fue el enfoque más sencillo y directo que pude encontrar por mi cuenta. ¡Disfrutar! :)

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

Cuando se ejecuta, el script produce lo siguiente:

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