Sözləri digər sözlərlə birlikdə ən çox tapın.

Mən Perl (5.8.8) -dən ən çox məktubları bir ardıcıl olaraq digər sözlərlə - ancaq eyni yerdə olan məktubları anlamaq istərdim. (Və libs istifadə etmədən üstünlük verirlər.)

Sözlər siyahısına nümunə olaraq baxın:

  • BAKER
  • Mototexnika
  • BALER
  • CARER
  • RUFFR

Onun BALER başqaları ilə ən ümumi xüsusiyyətlərə malik bir sözdür. Bu BAKER-da BAXER, SALER-də xALER, CARER-də xAxER və RUFFR-də xxxxR uyğun gəlir.

Mən Perlə bu sözü mənim üçün eyni uzunluğu və işi olan sözlərin birbaşa siyahısında tapmasını istəyirik. Buraya divar vurduğum kimi görünür, yardım çox yüksək qiymətləndirilir!

Bu günə qədər sınadığım şey

Hal-hazırda bir sıra script yoxdur:

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

Bir şərh varsa, for-loops və ++ varables ilə ağır bir neçə kodu cəhd. İndiyə qədər cəhdlərimin heç biri mənə lazım olan şeyi etməmişdi.

Beləliklə, daha yaxşı bir şəkildə izah etmək üçün: siyahıya qarşı hər sözün, hər bir əlifba mövqeyinin, ən çox məktubları olan bir sözü tapmaq üçün, sözügedən məktubda mövqeyini yoxlamaq lazımdır.

Birincisi, ilk növbədə hər hansı bir sözü (lərin) hərf 0-də mövqeyində ən ümumi mənaya sahib olduğunu yoxlamaq, daha sonra məktubun 1-i və s. siyahıdakı digər sözlərlə yanaşı. Daha sonra, hər bir məktub mövqeyinə görə hər bir söz üçün ümumi hesabı, DavidO təklif etdiyindən fərqli olaraq, siyahı matrix olaraq çap etmək istərdim.

Nəticədə hər bir söz üçün bir matris alırsınız, məktubun hər bir mövqeyi və matrisin hər bir sözü üçün ümumi bir hesab üçün qiymətləndirmə ilə.

Proqramın məqsədi

Hehe, mən də bunu söyləyə bilərəm: proqram Fallout 3 oyununda terminalleri çatdırmaq üçün nəzərdə tutulmuşdur .: D Mən Perl öyrənmək üçün yaxşı bir yol olduğunu düşünürəm və həmçinin əyləncəli oyunlar oynayır.

Araşdırmalar üçün istifadə edilən Fallout 3 terminalının təhqir edilməsi üzrə dərsliklərdən biri: Fallout 3: cracking v1.2 ilə bağlı suallar , məsələn, sözlərin siyahısını qısaltmaq üçün bir proqram hazırladıq:

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

Bu skript, nəticədə, oyunun SSS-də olduğu kimi, CONSTRUCTIONTRANSMISSION verəcəkdir. Lakin, orijinal suala (və mən özümdə başa düşə bilmədim) olan hiylə ilk cəhd etmək üçün ən yaxşı sözü necə tapmaq olar, yəni. APPRECIATION .

Tamam, mən indi sizin yardımınıza əsaslanan öz həllini təqdim etmişəm və bu mövzunu bağladıq. Bir çox, bütün iştirakçılara çox təşəkkür edirəm. Həqiqətən çox kömək etdiniz və yolda çox şey öyrəndim: D

6
10 июля '11 в 8:04 2011-07-10 08:04 Kebman , 10 İyul tarixində saat 08:04 'da təyin olunub . 2011-07-10 08:04
@ 8 cavab

Bir başlanğıc nöqtəsi olaraq, nə qədər məktubları effektiv şəkildə yoxlaya bilərsiniz:

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

Lakin bu, yalnız bu halda zəruri olmayan bütün mümkün söz cütlərini çevirsəniz faydalıdır:

 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 в 8:19 2011-07-10 08:19 Cavab ysth tərəfindən 10 iyul 'da 8:19' də verildi 2011-07-10 08:19

Burada bir yoldur. Sizin spesifikasiyanı bir neçə dəfə oxuduğunuzdan sonra, bu sizin aradığınız şeydir.

Qeyd edək ki, bərabər yuxarı hesabla birdən artıq söz olacaqdır. Siyahınızdan yalnız bir qələbə var, lakin daha uzun bir siyahıda bir neçə dərəcədə bərabər sözlər olacaqdır. Bu qərar bununla bağlıdır. Bundan əlavə, mən başa düşdüyüm kimi, məktubları bir sözlə bir sütunda görünsələr, uyğunlaşmaq üçün düşünürsən. Əgər belədirsə, onda burada işləyən bir həlldir:

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

Bu həll hər bir məktubun hər sütununun digər sözlərlə uyğun olduğu sayını sayar. Məsələn:

 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. 

Bu, ABC və ABŞ-ın qaliblərini, hər birinə dörd mövqeyə sahib olan bir matçla baxır. Yəni, bir sütun bir, bir satır bir sütun bir sıra iki, üç və dörd uyğun və s. Sonrakı sütunlar üçün. Optimallaşdırıla bilər və daha qısa müddətdə yenidən düzəldə bilərik, amma məntiqini tamamilə oxunandırmağa çalışdım. Enjoy!

border=0

UPDATE / EDIT Mən düşündüm və başa düşdüm ki, mövcud üsulum ilk sualınızın tələb etdiyinə tam baxdığına baxmayaraq, nisbətən yavaş olan O (n ^ 2) dəfədir. Hər bir sütun məktubu (hər düyməyə bir məktub) üçün hash düymələrindən istifadə edər və hər bir məktub sütunda (hash elementinin dəyəri kimi) neçə dəfə saya bilsək, O (1) məbləğlərimizi və siyahımızı traversal O (n * c) vaxtında (burada c sütunların sayı, n - sözlərin sayıdır). Ayarlanma vaxtı (hash yaradılması) da var. Amma biz hələ də böyük irəliləyişlərə sahibik. Burada hər bir texnologiyanın yeni versiyası və onların hər birinin müqayisəli müqayisəsi var.

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

Nəticə:

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

Bəzi variantları gördükdən sonra və müəyyən bir dərəcədə innovasiyanın bu xarakterini gördükdən sonra orijinal göstəricinizin dəyişdiyini başa düşürəm, amma bulmacam hələ də ağlımdadır. Gördüyünüz kimi, mənim hash üsulu orijinal üsuldan 287% daha sürətli. Daha az vaxtda daha çox əyləncə!

7
10 июля '11 в 8:32 2011-07-10 08:32 Cavab DavidO tərəfindən 10 iyul 'da 8:32' də verildi 2011-07-10 08:32

Burada tam skriptdir. O, yht kimi eyni fikirdədir (mən müstəqil olsa da). Lətifləri birləşdirmək üçün bitwise xor istifadə edin və nəticədə NUL sayını sayın. Sizin xətləri ASCII olduğu müddətcə, bu, neçə eşleme məktubunun olduğunu bildirəcəkdir. (Bu müqayisədə vəziyyətə həssasdır və strings UTF-8 olduqda nə olacağına əmin deyiləm.

 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 в 8:29 2011-07-10 08:29 Cavab 10 iyul 2011-ci il tarixində saat 08 : 29 -da veriləcək

Bir müddət sonra perlə toxunmayın, buna görə pseudocode bu. Bu ən sürətli alqoritm deyil, lakin az sayda söz üçün yaxşı işləyəcək.

 totals = new map #eg 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 olmaması üçün üzr istəyirik, ancaq Perl'də göstərdiyiniz təqdirdə bir cazibədarlıq kimi işləməlidir.

Əməliyyat müddətində tez qeyd: bu, number_of_words ^ 2 * length_of_words ilə işləyəcək , belə ki 100 sözün birində, 10 simvolun hər biri 100,000 döngü ilə tətbiq ediləcək , bu da bir çox proqram üçün uyğundur.

2
10 июля '11 в 8:15 2011-07-10 08:15 cavab 10 iyul 2011-ci il tarixində saat 08:15 radələrində ghayes tərəfindən verilmişdir

Eyni simvolları saymaq üçün sözü sargısına əsaslanan bir versiya. Mən kodunuz deyil, mənbə müqayisələrindən sözlər istifadə etdim.

Bu, hər hansı bir uzun söz və uzunluqların siyahısı ilə işləməlidir. Çıxış:

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

Kod:

 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 =~ /([AZ])/ ) { 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 в 15:26 2011-07-10 15:26 cavab TLP tərəfindən 10 iyul 2011-ci il saat 15:26 da verilir. 2011-07-10 15:26

Cavab vermək cəhdi. Buna da ehtiyac varsa, hər bir fərdi matçı görmək imkanı verir. (yəni BALER BAKER-da 4 simvol eşleşir). EDIT : sözlər arasında bir əlaqə varsa (mən "CAKER" ı checklistə əlavə etdikdə) o, bütün matçları tutur.

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

Nəticə sadədir: CAKER BALER və BAKER.

%wordcomparison hash %wordcomparison kimi görünür:

 'SALER' { 'RUFFR' => 1, 'BALER' => 4, 'BAKER' => 3, 'total' => 11, 'CARER' => 3 }; 
1
10 июля '11 в 12:09 2011-07-10 12:09 Cavab Jon 10 iyul 'da 12:09' də verildi 2011-07-10 12:09

Bütün investorlara çox təşəkkür edirik! Əlbəttə ki, mənə hələ çox öyrənmək üçün çox şey göstərdiyini göstərdiniz, amma öz cavabınızı inkişaf etdirməkdə mənə çox kömək etdiniz. Mən bunu sadəcə istinad və mümkün geribildirim üçün buraya qoyuram, çünki bunu etmək üçün daha yaxşı yollar var. Mənim üçün bu, mənim özümün tapa biləcəyi ən sadə və ən doğru yanaşma idi. Enjoy!

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

Skripti çalıştırdığınızda aşağıdakıları görüntüler:

 BAKER: 11 SALER: 11 BALER: 12 <- best CARER: 10 RUFFR: 4 
0
16 июля '11 в 3:17 2011-07-16 03:17 Kevmanın 16 iyul 'da 3:17' də cevaplaması 2011-07-16 03:17

Məktubun yeri ilə uyğunlaşdıqda kodu yerinə yetirmək üçün kirli regex oyunundan istifadə edə bilərsiniz, lakin əksinə, xoşbəxtlikdən yol boyunca müntəzəm ifadələr yaratmaq çox asandır:

Daimi ifadə nümunəsi:

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

Tez ola bilər və ya ola bilməz.

 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 aldatmasının istifadə edilməsi tez olacaq, ancaq qarşılaşa biləcəyiniz bir çox karakter aralığını ehtiva edir. Bu halda utf-8'in pozulacağı bir çox yol var.

0
10 июля '11 в 8:38 2011-07-10 08:38 cavab 10 iyul 'da 8:38' də Alex tərəfindən verildi 2011-07-10 08:38

Etiket bağlı digər suallar və ya bir sual vermək