File Coverage

blib/lib/Games/LMSolve/Base.pm
Criterion Covered Total %
statement 75 167 44.9
branch 10 34 29.4
condition 2 9 22.2
subroutine 13 29 44.8
pod 17 17 100.0
total 117 256 45.7


line stmt bran cond sub pod time code
1             package Games::LMSolve::Base;
2              
3 2     2   13 use strict;
  2         4  
  2         59  
4 2     2   12 use warnings;
  2         3  
  2         48  
5              
6 2     2   1524 use Getopt::Long;
  2         26733  
  2         10  
7              
8             our $VERSION = '0.8.6';
9              
10 2     2   358 use Exporter;
  2         6  
  2         74  
11              
12 2     2   12 use vars qw(@ISA @EXPORT_OK);
  2         4  
  2         128  
13              
14             @ISA = qw(Exporter);
15              
16             @EXPORT_OK = qw(%cell_dirs);
17              
18 2     2   11 use vars qw(%cell_dirs);
  2         5  
  2         3799  
19              
20             %cell_dirs = (
21             'N' => [ 0, -1 ],
22             'NW' => [ -1, -1 ],
23             'NE' => [ 1, -1 ],
24             'S' => [ 0, 1 ],
25             'SE' => [ 1, 1 ],
26             'SW' => [ -1, 1 ],
27             'E' => [ 1, 0 ],
28             'W' => [ -1, 0 ],
29             );
30              
31              
32             sub new
33             {
34 1     1 1 1015 my $class = shift;
35              
36 1         3 my $self = {};
37              
38 1         3 bless $self, $class;
39              
40 1         8 $self->initialize(@_);
41              
42 1         3 return $self;
43             }
44              
45             sub initialize
46             {
47 1     1 1 3 my $self = shift;
48              
49 1         7 $self->{'state_collection'} = {};
50 1         5 $self->{'cmd_line'} = { 'scan' => "brfs", };
51              
52 1         3 $self->{'num_iters'} = 0;
53              
54 1         4 return 0;
55             }
56              
57              
58             my %scan_functions = (
59             'dfs' => sub {
60             my $self = shift;
61              
62             return $self->_solve_brfs_or_dfs( 1, @_ );
63             },
64             'brfs' => sub {
65             my $self = shift;
66              
67             return $self->_solve_brfs_or_dfs( 0, @_ );
68             },
69             );
70              
71             sub main
72             {
73 0     0 1 0 my $self = shift;
74              
75             # This is a flag that specifies whether to present the moves in Run-Length
76             # Encoding.
77 0         0 my $to_rle = 1;
78 0         0 my $output_states = 0;
79 0         0 my $scan = "brfs";
80 0         0 my $run_time_states_display = 0;
81              
82             #my $p = Getopt::Long::Parser->new();
83 0 0       0 if (
84             !GetOptions(
85             'rle!' => \$to_rle,
86             'output-states!' => \$output_states,
87             'method=s' => \$scan,
88             'rtd!' => \$run_time_states_display,
89             )
90             )
91             {
92 0         0 die "Incorrect options passed!\n";
93             }
94              
95 0 0       0 if ( !exists( $scan_functions{$scan} ) )
96             {
97 0         0 die "Unknown scan \"$scan\"!\n";
98             }
99              
100 0         0 $self->{'cmd_line'}->{'to_rle'} = $to_rle;
101 0         0 $self->{'cmd_line'}->{'output_states'} = $output_states;
102 0         0 $self->{'cmd_line'}->{'scan'} = $scan;
103 0   0     0 $self->set_run_time_states_display( $run_time_states_display
104             && \&_default_rtd_callback );
105              
106 0   0     0 my $filename = shift(@ARGV) || "board.txt";
107              
108 0         0 my @ret = $self->solve_board($filename);
109              
110 0         0 $self->display_solution(@ret);
111             }
112              
113              
114             sub _die_on_abstract_function
115             {
116             my (
117 0     0   0 $package, $filename, $line, $subroutine, $hasargs,
118             $wantarray, $evaltext, $is_require, $hints, $bitmask
119             ) = caller(1);
120 0         0 die( "The abstract function $subroutine() was "
121             . "called, while it needs to be overrided by the derived class.\n"
122             );
123             }
124              
125              
126             sub input_board
127             {
128 0     0 1 0 return _die_on_abstract_function();
129             }
130              
131              
132             # A function that accepts the expanded state (as an array ref)
133             # and returns an atom that represents it.
134             sub pack_state
135             {
136 0     0 1 0 return _die_on_abstract_function();
137             }
138              
139              
140             # A function that accepts an atom that represents a state
141             # and returns an array ref that represents it.
142             sub unpack_state
143             {
144 0     0 1 0 return _die_on_abstract_function();
145             }
146              
147              
148             # Accept an atom that represents a state and output a
149             # user-readable string that describes it.
150             sub display_state
151             {
152 0     0 1 0 return _die_on_abstract_function();
153             }
154              
155              
156             sub check_if_final_state
157             {
158 0     0 1 0 return _die_on_abstract_function();
159             }
160              
161              
162             # This function enumerates the moves accessible to the state.
163             # If it returns a move, it still does not mean that this move is a valid
164             # one. I.e: it is possible that it is illegal to perform it.
165             sub enumerate_moves
166             {
167 0     0 1 0 return _die_on_abstract_function();
168             }
169              
170              
171             # This function accepts a state and a move. It tries to perform the
172             # move on the state. If it is succesful, it returns the new state.
173             #
174             # Else, it returns undef to indicate that the move is not possible.
175             sub perform_move
176             {
177 0     0 1 0 return _die_on_abstract_function();
178             }
179              
180              
181             # This function checks if a state it receives as an argument is a
182             # dead-end one.
183             sub check_if_unsolvable
184             {
185 83     83 1 161 return 0;
186             }
187              
188              
189             # This is a function that should be overrided in case
190             # rendering the move into a string is non-trivial.
191             sub render_move
192             {
193 0     0 1 0 my $self = shift;
194              
195 0         0 my $move = shift;
196              
197 0 0       0 return defined($move) ? $move : "";
198             }
199              
200              
201             sub _solve_brfs_or_dfs
202             {
203 1     1   3 my $self = shift;
204 1         3 my $state_collection = $self->{'state_collection'};
205 1         3 my $is_dfs = shift;
206 1         3 my %args = @_;
207              
208 1         3 my $run_time_display = $self->{'cmd_line'}->{'rt_states_display'};
209 1         2 my $rtd_callback = $self->{'run_time_display_callback'};
210 1   50     6 my $max_iters = $args{'max_iters'} || (-1);
211 1         3 my $check_iters = ( $max_iters >= 0 );
212              
213 1         2 my ( @queue, $state, $coords, $depth, @moves, $new_state );
214              
215 1 50       3 if ( exists( $args{'initial_state'} ) )
216             {
217 1         3 push @queue, $args{'initial_state'};
218             }
219              
220 1         2 my @ret;
221              
222 1         2 @ret = ( "unsolved", undef );
223              
224 1         4 while ( scalar(@queue) )
225             {
226 83 50 33     194 if ( $check_iters && ( $max_iters <= $self->{'num_iters'} ) )
227             {
228 0         0 @ret = ( "interrupted", undef );
229 0         0 goto Return;
230             }
231 83 50       145 if ($is_dfs)
232             {
233 0         0 $state = pop(@queue);
234             }
235             else
236             {
237 83         145 $state = shift(@queue);
238             }
239 83         192 $coords = $self->unpack_state($state);
240 83         162 $depth = $state_collection->{$state}->{'d'};
241              
242 83         144 $self->{'num_iters'}++;
243              
244             # Output the current state to the screen, assuming this option
245             # is set.
246 83 50       165 if ($run_time_display)
247             {
248             $rtd_callback->(
249             $self,
250             'depth' => $depth,
251             'state' => $coords,
252 0         0 'move' => $state_collection->{$state}->{'m'},
253             );
254              
255             # print ((" " x $depth) . join(",", @$coords) . " M=" . $self->render_move($state_collection->{$state}->{'m'}) ."\n");
256             }
257              
258 83 50       181 if ( $self->check_if_unsolvable($coords) )
259             {
260 0         0 next;
261             }
262              
263 83 100       208 if ( $self->check_if_final_state($coords) )
264             {
265 1         3 @ret = ( "solved", $state );
266 1         16 goto Return;
267             }
268              
269 82         224 @moves = $self->enumerate_moves($coords);
270              
271 82         155 foreach my $m (@moves)
272             {
273 238         563 my $new_coords = $self->perform_move( $coords, $m );
274              
275             # Check if this move leads nowhere and if so - skip to the next move.
276 238 50       495 if ( !defined($new_coords) )
277             {
278 0         0 next;
279             }
280              
281 238         594 $new_state = $self->pack_state($new_coords);
282 238 100       690 if ( !exists( $state_collection->{$new_state} ) )
283             {
284 85         329 $state_collection->{$new_state} = {
285             'p' => $state,
286             'm' => $m,
287             'd' => ( $depth + 1 )
288             };
289 85         263 push @queue, $new_state;
290             }
291             }
292             }
293              
294             Return:
295              
296 1         18 return @ret;
297             }
298              
299             sub _run_length_encoding
300             {
301 0     0   0 my @moves = @_;
302 0         0 my @ret = ();
303              
304 0         0 my $prev_m = shift(@moves);
305 0         0 my $count = 1;
306 0         0 my $m;
307 0         0 while ( $m = shift(@moves) )
308             {
309 0 0       0 if ( $m eq $prev_m )
310             {
311 0         0 $count++;
312             }
313             else
314             {
315 0         0 push @ret, [ $prev_m, $count ];
316 0         0 $prev_m = $m;
317 0         0 $count = 1;
318             }
319             }
320 0         0 push @ret, [ $prev_m, $count ];
321              
322 0         0 return @ret;
323             }
324              
325             sub _solve_state
326             {
327 1     1   2 my $self = shift;
328              
329 1         2 my $initial_coords = shift;
330              
331 1         5 my $state = $self->pack_state($initial_coords);
332 1         5 $self->{'state_collection'}->{$state} = { 'p' => undef, 'd' => 0 };
333              
334 1         6 return $self->run_scan(
335             'initial_state' => $state,
336             @_
337             );
338             }
339              
340              
341             sub solve_board
342             {
343 1     1 1 9 my $self = shift;
344              
345 1         3 my $filename = shift;
346              
347 1         4 my $initial_coords = $self->input_board($filename);
348              
349 1         10 return $self->_solve_state( $initial_coords, @_ );
350             }
351              
352              
353             sub run_scan
354             {
355 1     1 1 2 my $self = shift;
356              
357 1         4 my %args = @_;
358              
359 1         5 return $scan_functions{ $self->{'cmd_line'}->{'scan'} }->( $self, %args );
360             }
361              
362              
363             sub get_num_iters
364             {
365 0     0 1   my $self = shift;
366              
367 0           return $self->{'num_iters'};
368             }
369              
370              
371             sub display_solution
372             {
373 0     0 1   my $self = shift;
374              
375 0           my @ret = @_;
376              
377 0           my $state_collection = $self->{'state_collection'};
378              
379 0           my $output_states = $self->{'cmd_line'}->{'output_states'};
380 0           my $to_rle = $self->{'cmd_line'}->{'to_rle'};
381              
382             my $echo_state = sub {
383 0     0     my $state = shift;
384 0 0         return $output_states
385             ? ( $self->display_state($state) . ": Move = " )
386             : "";
387 0           };
388              
389 0           print $ret[0], "\n";
390              
391 0 0         if ( $ret[0] eq "solved" )
392             {
393 0           my $key = $ret[1];
394 0           my $s = $state_collection->{$key};
395 0           my @moves = ();
396 0           my @states = ($key);
397              
398 0           while ( $s->{'p'} )
399             {
400 0           push @moves, $s->{'m'};
401 0           $key = $s->{'p'};
402 0           $s = $state_collection->{$key};
403 0           push @states, $key;
404             }
405 0           @moves = reverse(@moves);
406 0           @states = reverse(@states);
407 0           my $num_state;
408 0 0         if ($to_rle)
409             {
410 0           my @moves_rle = _run_length_encoding(@moves);
411              
412 0           $num_state = 0;
413 0           foreach my $m (@moves_rle)
414             {
415 0           print $echo_state->( $states[$num_state] )
416             . $self->render_move( $m->[0] ) . " * "
417             . $m->[1] . "\n";
418 0           $num_state += $m->[1];
419             }
420             }
421             else
422             {
423 0           for ( $num_state = 0 ; $num_state < scalar(@moves) ; $num_state++ )
424             {
425 0           print $echo_state->( $states[$num_state] )
426             . $self->render_move( $moves[$num_state] ) . "\n";
427             }
428             }
429 0 0         if ($output_states)
430             {
431 0           print $self->display_state( $states[$num_state] ), "\n";
432             }
433             }
434             }
435              
436             sub _default_rtd_callback
437             {
438 0     0     my $self = shift;
439              
440 0           my %args = @_;
441             print(( " " x $args{depth} )
442 0           . join( ",", @{ $args{state} } ) . " M="
443             . $self->render_move( $args{move} )
444 0           . "\n" );
445             }
446              
447              
448             sub set_run_time_states_display
449             {
450 0     0 1   my $self = shift;
451 0           my $states_display = shift;
452              
453 0 0         if ( !$states_display )
454             {
455 0           $self->{'cmd_line'}->{'rt_states_display'} = undef;
456             }
457             else
458             {
459 0           $self->{'cmd_line'}->{'rt_states_display'} = 1;
460 0           $self->{'run_time_display_callback'} = $states_display;
461             }
462              
463 0           return 0;
464             }
465              
466              
467             1;
468              
469             __END__