Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
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 contemplating the Monastery: (11)
As of 2014-09-22 11:21 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (189 votes), past polls