in reply to Another word puzzle with too many permutations
Here is a backtracking method which works on sorted data, dogs with rare letters first. (Similar to LanX's proposal.)
use strict; use warnings; use Data::Dumper; sub score { my ($dog, $letters) = @_; my $sum = 0; $sum += $$letters{$_}//0 for grep {/\w/} split //, $dog; return $sum/length($dog); } my @n = qw(Affenpinscher AfghanHound AiredaleTerrier Akita AlaskanMala +mute AmericanEnglishCoonhound AmericanEskimoDog AmericanFoxhound Base +nji BassetHound Beagle BeardedCollie Beauceron BlackandTanCoonhound B +loodhound BluetickCoonhound BorderCollie BorderTerrier Borzoi BostonT +errier BouvierdesFlandres Boxer BoykinSpaniel Briard Brittany Brussel +sGriffon BullTerrier Bulldog Bullmastiff ChesapeakeBayRetriever Chihu +ahua ChineseCrested ChineseShar-Pei Chinook ChowChow ClumberSpaniel C +ockerSpaniel Collie Curly-CoatedRetriever Dachshund Dalmatian DandieD +inmontTerrier DobermanPinscher DoguedeBordeaux EnglishCockerSpaniel E +nglishFoxhound EnglishSetter EnglishSpringerSpaniel GermanPinscher Ge +rmanShepherdDog GermanShorthairedPointer GermanWirehairedPointer Gian +tSchnauzer GlenofImaalTerrier GoldenRetriever GordonSetter GreatDane +Greyhound Harrier IbizanHound IcelandicSheepdog IrishSetter IrishTerr +ier Kuvasz LabradorRetriever LakelandTerrier LhasaApso Lowchen Maltes +e ManchesterTerrier Mastiff MiniatureBullTerrier MiniaturePinscher Mi +niatureSchnauzer NeapolitanMastiff Newfoundland NorfolkTerrier Peking +ese PembrokeWelshCorgi PharaohHound Plott PortugueseWaterDog Pug Puli + PyreneanShepherd RatTerrier ShibaInu ShihTzu SiberianHusky SilkyTerr +ier SkyeTerrier SmoothFoxTerrier SoftCoatedWheatenTerrier SpinoneItal +iano St.Bernard StaffordshireBullTerrier WireFoxTerrier WirehairedPoi +ntingGriffon Xoloitzcuintli YorkshireTerrier); my $letters = "A(8),B(2),C(5),D(8),E(7),F(1),G(3),H(9),I(8),K(1),L(9), +M(1),N(12),O(13),P(1),Q(0),R(5),S(6),T(4),U(6),V(0),W(1),X(1),Y(0),Z( +1)"; my %letters = map { /(\w)\((\d+)\)/; { $1 => $2 } } split /,/, $letter +s; @n = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, score( $ +_, \%letters ) ] } @n; $letters = join '', sort { length $a <=> length $b } map { /(\w)\((\d+ +)\)/; $2?$1 x $2:'' } split /,/, $letters; sub dogtree { my ( $level, $tree, $letters, @dogs ) = @_; print "$tree\n" and exit unless $letters; DOG: while( my $dog = shift @dogs) { my $remaining = $letters; $remaining =~ s/$_//i or next DOG for grep { /\w/ } split //, $dog +; dogtree( $level+1, "$tree $dog", $remaining, @dogs ); } } dogtree 0, '', $letters, @n;
Takes 14 seconds on my machine to find one solution.
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re^2: Another word puzzle with too many permutations
by sarchasm (Acolyte) on Oct 15, 2013 at 21:34 UTC | |
by oiskuu (Hermit) on Oct 15, 2013 at 22:13 UTC | |
by LanX (Saint) on Oct 16, 2013 at 16:07 UTC | |
by hdb (Monsignor) on Oct 16, 2013 at 06:57 UTC | |
by oiskuu (Hermit) on Oct 16, 2013 at 16:24 UTC |