File Coverage

blib/lib/Freecell/App.pm
Criterion Covered Total %
statement 24 191 12.5
branch 0 62 0.0
condition 0 14 0.0
subroutine 8 20 40.0
pod 11 11 100.0
total 43 298 14.4


line stmt bran cond sub pod time code
1             package Freecell::App;
2 1     1   24922 use version;
  1         2370  
  1         5  
3             our $VERSION = '0.03';
4 1     1   74 use warnings;
  1         3  
  1         29  
5 1     1   5 use strict;
  1         6  
  1         25  
6 1     1   674 use Freecell::App::Tableau;
  1         4  
  1         32  
7 1     1   1210 use Getopt::Long;
  1         15374  
  1         10  
8 1     1   1610 use Log::Log4perl;
  1         59445  
  1         8  
9 1     1   968 use File::Slurp;
  1         17334  
  1         101  
10 1     1   13 use List::Util qw(min);
  1         15  
  1         3233  
11            
12             my $QUIT_NOW = 0;
13             $SIG{'INT'} = sub { $QUIT_NOW = 1 };
14            
15             my $cnt; # new positions
16             my $dup; # potential dupes
17             my $tot = 0;
18             my $found = 0;
19             my $depth = 0; # maxnodes estimates - sometimes better solution when higher
20             my $max_depth = 55; # 2000 < 2GB, 5-10 mins to solve, perl x86 (32bit) ok
21             my $max_nodes = 2000; # 25000 ~ 2GB, 20-40 mins to solve, perl x64 (64bit) only
22             my $game_no = 0; # 100000 > 4GB, over 2 hrs to solve
23             my $log_stats = 0; # 250000 > 16GB, out_of_memory!
24             my $show_all = 0;
25             my $fcgsfile = '';
26             my %stats;
27             my @solution;
28             my $position; # seen layouts
29             my $logger;
30            
31             sub getopts {
32            
33             my $result = GetOptions(
34             "gameno:i" => \$game_no, #numeric
35             "maxnodes:i" => \$max_nodes, #numeric
36 0     0     "winxp!" => sub { Freecell::App::Tableau->winxp_opt($_[1]) },
37 0     0 1   "showall!" => \$show_all, #boolean
38             "maxdepth:i" => \$max_depth, #numeric
39             "logstats!" => \$log_stats, #boolean
40             "analyze:s" => \$fcgsfile, #string
41             );
42 0 0 0       usage_quit(0) if !($result and ($game_no == -1 or $game_no >= 1 and $game_no <= 1_000_000 or $fcgsfile));
43            
44             sub usage_quit {
45            
46             # Emit usage message, then exit with given error code.
47 0     0 1   print <<"END_OF_MESSAGE"; exit;
  0            
48            
49             Usage:
50             freecell-solver [switches]
51             This will solve a selected game of Freecell.
52            
53             Switches:
54             --gameno number of freecell game to solve (required 1-1000000)
55             --maxnodes set maximum nodes per level to search (default 2000)
56             --winxp solve for windows xp (no supermove)(default --nowinxp)
57             --showall log all moves and layouts with solution (default --noshowall)
58             END_OF_MESSAGE
59             }
60             }
61            
62             sub initlog {
63            
64             # Initialize Logger
65 0     0 1   my $log_conf = q(
66             log4perl.rootLogger = DEBUG, LOG1, LOG2
67             log4perl.appender.LOG1 = Log::Log4perl::Appender::File
68             log4perl.appender.LOG1.filename = fc_0_01.log
69             log4perl.appender.LOG1.mode = append
70             log4perl.appender.LOG1.layout = Log::Log4perl::Layout::PatternLayout
71             log4perl.appender.LOG1.layout.ConversionPattern = %d %p %m %n
72            
73             log4perl.appender.LOG2 = Log::Log4perl::Appender::Screen
74             log4perl.appender.LOG2.stderr = 0
75             log4perl.appender.LOG2.layout = Log::Log4perl::Layout::PatternLayout
76             log4perl.appender.LOG2.layout.ConversionPattern = %d %p %m %n
77             );
78 0           Log::Log4perl::init( \$log_conf );
79 0           $logger = Log::Log4perl->get_logger();
80             }
81            
82             sub stats {
83 0     0 1   my $log = "stats\n";
84 0           foreach my $depth ( sort { $a <=> $b } keys %stats ) {
  0            
85 0           $log .= sprintf "%s\n", $depth;
86 0           foreach my $score ( sort { $a <=> $b } keys %{ $stats{$depth} } ) {
  0            
  0            
87 0 0         $log .= sprintf "\t%s\t%s\t%s\n", $score,
88 0           map { defined($_) ? $_ : " " }
89 0           @{ $stats{$depth}{$score} }[ 0, 1 ];
90             }
91             }
92 0           $log;
93             }
94            
95             sub out {
96 0     0 1   my ( $game_no, $max_nodes, @solution ) = @_;
97 0           my $depth = @solution;
98 0 0         my $file = sprintf "#%s %s %sk %s", $game_no, $depth, $max_nodes / 1000,
    0          
99             ( Freecell::App::Tableau->winxp_opt() ? "xp" : Freecell::App::Tableau->winxp_warn() ? "w7" : "all" );
100 0           my $log = "\n\n";
101 0           my $std = "\n\n#$game_no\n";
102 0           my $cnt = 0;
103 0           my $htm = <<"eof";
104             Freecell in Miniature $file
105            
106            
115             eof
116 0 0 0       $htm .=
117             "", map "
Game #$game_no (Windows "
118             . ( Freecell::App::Tableau->winxp_opt() || !Freecell::App::Tableau->winxp_warn() ? "XP, " : "" )
119             . "Vista, 7)\n";
120 0           $htm .= "
NoSNMoveToAutoplay to home\n";
121            
122 0           foreach (@solution) {
123 0           my ( $layout, $score0, $score1, @note ) = split /\t/, $_, 8;
124 0           $stats{ $note[0] - 1 }{$score0}[1] = scalar @solution;
125 0           $log .= "($score0) @note\n\n$layout";
126 0 0         $std .= $note[1] . ( ++$cnt % 8 ? " " : "\n" );
127 0 0         $htm .=
128             join( "", "
" . ( $_ ? $_ : " " ), @note ) . "\n";
129             }
130 0           $htm .= "
";
131 0 0         $htm =~ s/([A2-9TJQK])([DCHS])/($1 eq 'T'?10:$1).""/gse;
  0            
132 0           $file =~ s/ /_/g;
133 0           write_file "fc$file.htm", $htm;
134 0 0         $logger->info( $std, $log ) if $show_all;
135 0 0         $logger->info( stats() ) if $log_stats;
136             }
137            
138             sub std_notation {
139 0           map {
140 0           my ( $src_col, $src_row, $dst_col, $dst_row ) = @$_;
141 0 0         push @$_,
    0          
    0          
    0          
142             ( $src_row > 0 ? $src_col + 1
143             : $src_col > 3 ? "h"
144             : qw(a b c d) [$src_col] )
145             . ( $dst_row > -1 ? $dst_col + 1
146             : $dst_col > 3 ? "h"
147             : qw(a b c d) [$dst_col] );
148 0     0 1   } @{ $_[0] };
149             }
150            
151             sub analyze
152             { # move to empty column always moves max cards - potential problem !
153 0     0 1   my @recs = split /\s+/, read_file $fcgsfile;
154 0           ( $game_no = shift @recs ) =~ s/#//;
155 0 0         die "Invalid std notation: # + gameno" unless $game_no =~ /^\d+$/;
156 0 0         map { die "Invalid std notation: [1-8abcdh]{2}" unless /[1-8abcdh]{2}/ }
  0            
157             @recs;
158 0           my $tableau = Freecell::App::Tableau->new()->from_deal($game_no);
159 0           my ( $key, $token ) = $tableau->to_token();
160 0           my $score = $tableau->heuristic();
161 0           $stats{$depth}{ $score->[0] }[0]++;
162 0           $position->{$key} = [ 0, $token, [], $score, 0 ];
163            
164 0           foreach my $note (@recs) {
165 0           my $list = search($tableau);
166 0           map { std_notation($_) } @{$list};
  0            
  0            
167 0           my @move = grep $_->[0][5] eq $note, @{$list};
  0            
168 0           map $tableau->play($_), @{ $move[-1] };
  0            
169 0           $depth++;
170             }
171             }
172            
173             sub backtrack {
174 0     0 1   my $key = shift;
175 0           my $tableau;
176 0           while (1) {
177 0           my ( $depth, $token, $move ) = @{ $position->{$key} };
  0            
178 0 0         last unless $depth;
179 0           $tableau = Freecell::App::Tableau->new()->from_token( $key, $token );
180 0           $tableau->undo($move);
181 0           ( $key, $token ) = $tableau->to_token();
182 0           my @score = @{ $position->{$key}[3] };
  0            
183 0           my @node = $tableau->notation($move);
184 0           push @solution,
185             join( "\t", $tableau->to_string, @score, $depth, @node );
186             }
187             }
188            
189             sub search {
190 0     0 1   my $tableau = shift;
191 0           my $nodelist = $tableau->generate_nodelist();
192 0 0         if ( @$nodelist > 0 ) {
193 0           foreach my $node (@$nodelist) {
194 0           foreach my $move (@$node) {
195 0           $tableau->play($move);
196             }
197 0           $tableau->autoplay($node); # append autoplay to node
198 0           my ( $key, $token ) = $tableau->to_token();
199 0 0         if ( !exists( $position->{$key} ) ) {
200 0           $cnt++;
201 0           my $score = $tableau->heuristic();
202 0           $stats{ $depth + 1 }{ $score->[0] }[0]++;
203 0           $position->{$key} = [ $depth + 1, $token, $node, $score, 0 ];
204 0           my $state = join "", map Freecell::App::Tableau::rank( $_->[0] ),
205             @$tableau;
206 0 0         if ( "000013131313" eq $state ) {
207 0           backtrack($key);
208 0           out( $game_no, $max_nodes, reverse @solution );
209 0           $found = 1;
210             }
211             }
212 0           $dup++;
213 0           $tot++;
214 0           $tableau->undo($node);
215 0 0         if ($found) { last }
  0            
216 0 0         if ($QUIT_NOW) { $max_depth = $depth; last }
  0            
  0            
217             }
218             }
219 0           $nodelist;
220             }
221            
222             sub solve {
223            
224             #617 with 4 moves left (Xp invalid!)
225 0     0 1   my $input = <
226             KS 7C 9S 6S 5D 4C 5H 4S
227             7D 9C 5C KC 5S 8C KH 7S
228             TD QD QH 6D 8H QC
229             TH JC JS 8D JD
230             KD 7H TC
231             QS 6H 9D
232             JH 6C 8S
233             TS
234             9H
235             eof
236            
237 0 0         my $tableau = ( $game_no == -1 )
238             ? Freecell::App::Tableau->new()->from_string($input)
239             : Freecell::App::Tableau->new()->from_deal($game_no);
240            
241 0           my ( $key, $token ) = $tableau->to_token();
242 0           my $score = $tableau->heuristic();
243 0           undef %stats;
244 0           $stats{$depth}{ $score->[0] }[0]++;
245 0           undef $position;
246 0           $position->{$key} = [ $depth, $token, [], $score, 0 ];
247 0           undef @solution;
248            
249 0           $logger->info();
250 0 0         $logger->info( ". . .Starting --gameno $game_no --maxnodes $max_nodes ",
251             Freecell::App::Tableau->winxp_opt() ? "--winxp" : "--nowinxp" );
252 0           $logger->info();
253            
254 0   0       while ( $depth < $max_depth && !$found ) {
255 0           ( $cnt, $dup ) = (0) x 2;
256            
257             # splice top maxnodes positions
258            
259 0           my @s = sort { $position->{$a}[3][0] <=> $position->{$b}[3][0] }
  0            
260 0           grep { $depth == $position->{$_}[0] } keys %$position;
261 0           my $level_cnt = scalar @s;
262 0           my $mid_index = min( $max_nodes, $level_cnt ) - 1;
263 0           my @mid_score;
264 0           $mid_score[0] = $position->{ $s[$mid_index] }[3][0];
265 0           @s = sort { $position->{$a}[3][1] <=> $position->{$b}[3][1] } @s;
  0            
266 0           $mid_score[1] = $position->{ $s[$mid_index] }[3][1];
267            
268             #print Dumper \@mid_score;
269 0           my $lo_score = $position->{ $s[0] }[3][0];
270 0           my $hi_score = $position->{ $s[-1] }[3][0];
271            
272             # mark all kept positions
273            
274 0           my @stack;
275 0           foreach (@s) {
276 0           my $k = $_;
277 0           my $pos_score = $position->{$k}[3];
278 0 0 0       if ( $pos_score->[0] > $mid_score[0]
279             && $pos_score->[1] > $mid_score[1] )
280             {
281 0           next;
282             }
283 0           push @stack, [ $k, $position->{$k}[1] ];
284 0           while (1) {
285 0           my ( $d, $t, $m, $s, $l ) = @{ $position->{$k} };
  0            
286 0 0         if ( $depth == $l ) { last }
  0            
287 0           $position->{$k}[4] = $depth;
288 0 0         if ( $depth == 0 ) { last }
  0            
289 0           my $tableau = Freecell::App::Tableau->new()->from_token( $k, $t );
290 0           $tableau->undo($m);
291 0           ( $k, $t ) = $tableau->to_token();
292             }
293             }
294            
295             # delete all unmarked positions
296            
297 0           foreach my $k ( keys %$position ) {
298 0 0         unless ( $position->{$k}[4] == $depth ) {
299 0           delete $position->{$k};
300             }
301             }
302            
303             # search for new positions
304            
305 0           foreach (@stack) {
306 0           $tableau = Freecell::App::Tableau->new()->from_token(@$_);
307 0           search($tableau);
308             }
309 0   0       my $log =
310             sprintf
311             "d=%3d, s=%3d -%3d -%3d, l=%7d (%3d%%), cnt=%9d (%3d%%), p=%7d",
312             $depth, $lo_score, $mid_score[0], $hi_score, $level_cnt,
313             int( 100 * @stack / $level_cnt ), $dup,
314             int( 100 * $cnt / ( $dup || 1 ) ), scalar( keys %$position );
315 0           $logger->info($log);
316 0           $depth++;
317             }
318             }
319            
320             sub run {
321 0     0 1   getopts();
322 0           initlog();
323            
324 0 0         if ($fcgsfile) {
325 0           $max_nodes = 0;
326 0           $show_all = 1;
327 0           analyze($fcgsfile);
328             }
329             else {
330 0           solve();
331             }
332 0 0         unless ($QUIT_NOW){
333 0 0         $logger->info( sprintf "%-41s tot=%9d",
334             Freecell::App::Tableau->winxp_warn() ? ". . .Game solution not valid for XP!" : "", $tot )
335             }
336             }
337             run() unless caller;
338            
339             __END__