Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Re^2: Improve My FaceBook Scramble Solver

by Limbic~Region (Chancellor)
on Dec 09, 2011 at 00:23 UTC ( #942523=note: print w/ replies, xml ) Need Help??


in reply to Re: Improve My FaceBook Scramble Solver
in thread Improve My FaceBook Scramble Solver

Anonymous Monk,
In my code, you can see I generate the my_dict.db from a plain text word file (in my case, 'all_words.txt'). Any dictionary file will do. I believe I used one of the word lists from here initially.

I actually got the official word file from the developer Gareth Taft but I do not have his permission to post it publicly. Actually, I realize now that I never updated this node with my revised code after he explained the missing components of my reverse engineering of the rules. See below:

Score: 292,581,765 Biggest Chain: 3581 Highest Multiplier: 267 Best Word: JEEZ (172,125)
#!/usr/bin/perl use constant DEBUG => 1; use constant CHAIN => 0; use constant USED => 1; use constant POS_Q => 2; use constant LET_Q => 3; use strict; use warnings; use Storable; my %rule = ( 1 => { key => {}, place +=> {} }, 2 => { key => {2 => 1, 6 => 2, 10 => 3, 14 => 4, '*' => 5}, place +=> {} }, 3 => { key => {}, place +=> {3 => 1, '*' => 2} }, 0 => { key => {4 => 1, 8 => 2, 12 => 3, 16 => 4, '*' => 5}, place +=> {4 => 1, '*' => 2} } ); my $list = retrieve('word_list.db'); my $init = $ARGV[0] or die "Usage: $0 <word> <iterations>"; my $n = $ARGV[1] or die "Usage: $0 <word> <iterations>"; open(my $chain_fh, '>', "${init}_longest_chain.txt") or die $!; select $chain_fh; $| = 1; open(my $score_fh, '>', "${init}_highest_score.txt") or die $!; select $score_fh; $| = 1; select STDOUT; $| = 1; my @work; for (@{$list->{$init}}) { my %used = ($_->{word} => 1); my @chain = ($_); my (@pos_queue, @let_queue); push @work, [\@chain, \%used, \@pos_queue, \@let_queue]; } print scalar localtime(), "\n"; my $max_score = {chain => [], score => -1, len => -1}; my $max_chain = {chain => [], score => -1, len => -1}; while (@work) { last if ! $n--; my $item = pop @work; my $curr = $item->[CHAIN][-1]{word}; my $end_of_chain = 1; CANDIDATE: for (@{$list->{$curr}}) { my ($word, $pos, $let) = @{$_}{qw/word position letter/}; # Already used this word next CANDIDATE if $item->[USED]{$word}; my %used = %{$item->[USED]}; # Can't use this letter my @let_q = @{$item->[LET_Q]}; for (@let_q) { next CANDIDATE if $let eq $_; } # Can't use this position my @pos_q = @{$item->[POS_Q]}; for (@pos_q) { next CANDIDATE if $pos == $_; } my @chain = @{$item->[CHAIN]}; # Update info push @chain, $_; $used{$word} = 1; my $lvl = int(@chain / 10) + 1; my $style = $lvl % 4; # Handle left over queue shift @let_q if $style == 1 || $style == 3; shift @pos_q if $style == 1 || $style == 2; shift @let_q if let_q_full($style, $lvl, scalar @let_q); push @let_q, $let if $style == 2 || $style == 0; shift @pos_q if pos_q_full($style, $lvl, scalar @pos_q); push @pos_q, $pos if $style == 3 || $style == 0; # Add the new item to the work queue push @work, [\@chain, \%used, \@pos_q, \@let_q]; $end_of_chain = 0; } if ($end_of_chain) { my $count = @{$item->[CHAIN]}; my $score = calculate_score($item->[CHAIN]); if ($count > $max_chain->{len}) { $max_chain->{len} = $count; $max_chain->{score} = $score; $max_chain->{chain} = $item->[CHAIN]; if (DEBUG) { print "Found new longest chain: $count with score of $ +score\n"; } print $chain_fh join(' ', map $_->{word}, @{$item->[CHAIN] +}), "\n"; } if ($score > $max_score->{score}) { $max_score->{len} = $count; $max_score->{score} = $score; $max_score->{chain} = $item->[CHAIN]; if (DEBUG) { print "Found new high scoring chain: $count with score + of $score\n"; } print $score_fh join(' ', map $_->{word}, @{$item->[CHAIN] +}), "\n"; } } } print scalar localtime(), "\n"; sub let_q_full { my ($style, $lvl, $count) = @_; return if $style == 1 || $style == 3; my $full = $rule{$style}{key}{$lvl} || $rule{$style}{key}{'*'}; return $count >= $full; } sub pos_q_full { my ($style, $lvl, $count) = @_; return if $style == 1 || $style == 2; my $full = $rule{$style}{place}{$lvl} || $rule{$style}{place}{'*'} +; return $count >= $full; } sub calculate_score { my ($chain) = @_; my ($total, $multiplier, %bonus) = (0, 1, ()); for (@$chain) { my ($pos, $score) = @{$_}{qw/position score/}; if ($bonus{$pos}) { %bonus = ($pos => 1); } else { $bonus{$pos} = 1; } if (keys %bonus == 4) { $multiplier++; %bonus = (); } $total += ($score * $multiplier); } return $total; }
#!/usr/bin/perl use constant DELAY => 15; use strict; use warnings; use Storable; use Win32::GuiTest 'SendKeys'; my $list = retrieve('word_list.db'); my $word = $ARGV[0] or die "Usage: $0 <input_word>"; my $file = "${word}_highest_score.txt"; open(my $fh, '<', $file) or die "Unable to open '$file' for reading: $ +!"; my $last_line; while (<$fh>) { chomp; $last_line = $_; } my @guess = grep length($_) == 4, split ' ', $last_line; my ($curr, @chain) = ($list->{$word}, ()); GUESS: for my $want (@guess) { for my $have (@$curr) { if ($have->{word} eq $want) { push @chain, $have; $curr = $list->{$have->{word}}; next GUESS; } } } my $score = calculate_score(\@chain); print "Ready to get $score points (excludes time bonus)\n"; <STDIN>; sleep 5; my ($last_pos, $last_word) = (0, $word); for (@chain) { my ($word, $pos, $let) = @{$_}{qw/word position letter/}; move_position($last_pos, $pos) if $last_pos != $pos; $last_pos = $pos; print "Changing '$last_word' into '$word' by using $let at $pos\n" +; $last_word = $word; SendKeys($let, DELAY); } sub calculate_score { my ($chain) = @_; my ($total, $multiplier, %bonus) = (0, 1, ()); for (@$chain) { my ($pos, $score) = @{$_}{qw/position score/}; if ($bonus{$pos}) { %bonus = ($pos => 1); } else { $bonus{$pos} = 1; } if (keys %bonus == 4) { $multiplier++; %bonus = (); } $total += ($score * $multiplier); } return $total; } sub move_position { my ($src, $tgt) = @_; if ($src > $tgt) { SendKeys("{LEFT}", DELAY) for 1 .. $src - $tgt; } else { SendKeys("{RIGHT}", DELAY) for 1 .. $tgt - $src; } } sub get_next_word { my ($list, $used, $chain, $bonus, $rule) = @_; my $curr = @$chain ? $chain->[-1]{word} : $ARGV[0]; die "Usage: $0 <word>" if ! $curr; my ($best, $max) = ('', 0); { my %avail = map {$_ => 1} 0 .. 3; delete $avail{$_} for keys %$bonus; for my $neighbor (@{$list->{$curr}}) { my ($word, $pos, $let) = @{$neighbor}{qw/word position let +ter/}; next if $used->{$word} || ! $avail{$pos} || fails_rule($ch +ain, $rule, $pos, $let); my $count = @{$list->{$word}}; ($best, $max) = ($neighbor, $count) if $count > $max; } if (! $best) { return if ! %$bonus; %$bonus = (); redo; } } return $best; } sub fails_rule { my ($chain, $rule, $let, $pos) = @_; return if ! @$rule; my $ord = @$chain % 10; if ($rule->[$ord]) { for ( @{$rule->[$ord]{letter}} ) { return 1 if $let eq $chai +n->[$_]{letter}; }; for ( @{$rule->[$ord]{position}} ) { return 1 if $let eq $chai +n->[$_]{position}; }; } else { for ( @{$rule->[-1]{letter}} ) { return 1 if $let eq $chain- +>[$_]{letter}; }; for ( @{$rule->[-1]{position}} ) { return 1 if $let eq $chain- +>[$_]{position}; }; } return; }

Cheers - L~R


Comment on Re^2: Improve My FaceBook Scramble Solver
Select or Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://942523]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (17)
As of 2015-07-29 13:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (263 votes), past polls