File Coverage

blib/lib/Games/ABC_Path/Generator.pm
Criterion Covered Total %
statement 146 153 95.4
branch 17 22 77.2
condition 2 3 66.6
subroutine 26 26 100.0
pod 2 2 100.0
total 193 206 93.6


line stmt bran cond sub pod time code
1             package Games::ABC_Path::Generator;
2             $Games::ABC_Path::Generator::VERSION = '0.4.2';
3 2     2   149377 use 5.006;
  2         27  
4              
5 2     2   12 use strict;
  2         4  
  2         44  
6 2     2   20 use warnings;
  2         4  
  2         68  
7              
8 2     2   494 use integer;
  2         16  
  2         9  
9              
10 2     2   877 use parent 'Games::ABC_Path::Generator::Base';
  2         581  
  2         10  
11              
12 2     2   77 use Games::ABC_Path::Solver::Constants;
  2         4  
  2         217  
13 2     2   1036 use Games::ABC_Path::Solver::Board '0.1.0';
  2         20100  
  2         66  
14 2     2   830 use Games::ABC_Path::MicrosoftRand ();
  2         6  
  2         41  
15 2     2   871 use Games::ABC_Path::Generator::RiddleObj ();
  2         8  
  2         41  
16 2     2   880 use Games::ABC_Path::Generator::FinalLayoutObj ();
  2         12  
  2         41  
17 2     2   796 use Games::ABC_Path::Generator::Coord ();
  2         5  
  2         3265  
18              
19              
20             sub _init
21             {
22 1     1   106 my $self = shift;
23 1         3 my $args = shift;
24              
25 1         7 $self->{seed} = $args->{seed};
26              
27             $self->{rand} =
28 1         10 Games::ABC_Path::MicrosoftRand->new( seed => $self->{seed} );
29              
30 1         3 return;
31             }
32              
33             sub _shuffle
34             {
35 52     52   89 my ( $self, $deck ) = @_;
36              
37 52         134 return $self->{'rand'}->shuffle($deck);
38             }
39              
40             {
41             my @get_next_cells_lookup = (
42             map {
43             my $start = Games::ABC_Path::Generator::Coord->_from_int($_);
44             [
45             map {
46             my ( $y, $x ) =
47             ( $start->y() + $_->[$Y], $start->x() + $_->[$X] );
48             (
49             (
50             __PACKAGE__->_x_in_range($x)
51             && __PACKAGE__->_y_in_range($y)
52             ) ? ( __PACKAGE__->_xy_to_int( [ $y, $x ] ) ) : ()
53             )
54             } (
55             [ -1, -1 ], [ -1, 0 ], [ -1, 1 ], [ 0, -1 ],
56             [ 0, 1 ], [ 1, -1 ], [ 1, 0 ], [ 1, 1 ]
57             )
58             ]
59             } ( 0 .. $BOARD_SIZE - 1 )
60             );
61              
62             sub _get_next_cells
63             {
64 367     367   599 my ( $self, $l, $init_idx ) = @_;
65              
66 2001         3734 return [ grep { vec( $l, $_, 8 ) == 0 }
67 367         489 @{ $get_next_cells_lookup[$init_idx] } ];
  367         580  
68             }
69             }
70              
71             sub _add_next_state
72             {
73 28     28   55 my ( $self, $stack, $l, $cell_int ) = @_;
74              
75 28         82 vec( $l, $cell_int, 8 ) = 1 + @$stack;
76              
77 28         70 push @$stack,
78             [ $l, $self->_shuffle( $self->_get_next_cells( $l, $cell_int ) ) ];
79              
80 28         68 return;
81             }
82              
83             sub _get_num_connected
84             {
85 30     30   51 my ( $self, $l ) = @_;
86              
87 30         61 my @connectivity_stack = ( index( $l, "\0" ) );
88              
89 30         52 my %connected;
90 30         61 while (@connectivity_stack)
91             {
92 707         1062 my $int = pop(@connectivity_stack);
93 707 100       1544 if ( !$connected{$int}++ )
94             {
95             push @connectivity_stack,
96 1354         2895 ( grep { !exists( $connected{$_} ) }
97 339         456 @{ $self->_get_next_cells( $l, $int ) } );
  339         591  
98             }
99             }
100              
101 30         129 return scalar keys %connected;
102             }
103              
104              
105             sub calc_final_layout
106             {
107 1     1 1 29 my $self = shift;
108              
109 1         3 my @dfs_stack;
110             $self->_add_next_state( \@dfs_stack, '',
111 1         6 $self->{rand}->max_rand($BOARD_SIZE) );
112              
113             DFS:
114 1         3 while (@dfs_stack)
115             {
116 31         47 my ( $l, $last_cells ) = @{ $dfs_stack[-1] };
  31         61  
117              
118 31 100       63 if ( @dfs_stack == $BOARD_SIZE )
119             {
120 1         15 return Games::ABC_Path::Generator::FinalLayoutObj->new(
121             { layout_string => $l, },
122             );
123             }
124              
125             # print "Depth = " . scalar(@dfs_stack) . "\n";
126             # print "Last state = " . Dumper($last_state) . "\n";
127             # print "Layout = \n" . $self->get_layout_as_string($last_state->{layout}) . "\n";
128              
129 30         44 my $next_idx = shift(@$last_cells);
130              
131 30 100 66     77 if (
132             ( !defined($next_idx) )
133             or ( $self->_get_num_connected($l) !=
134             ( $BOARD_SIZE - scalar(@dfs_stack) ) )
135             )
136             {
137 3         8 pop(@dfs_stack);
138             }
139             else
140             {
141 27         58 $self->_add_next_state( \@dfs_stack, $l, $next_idx );
142             }
143             }
144              
145 0         0 die "Not found!";
146             }
147              
148              
149             sub _gen_clue_positions
150             {
151 24     24   38 my ( $self, $cb ) = @_;
152 24         50 return [ map { $cb->($_) } $self->_x_indexes() ];
  120         224  
153             }
154              
155             sub _calc_clue_positions
156             {
157 2     2   4 my $self = shift;
158             return [
159             map {
160 120         492 [ map { $self->_xy_to_int($_) }
161 24         132 @{ $self->_gen_clue_positions($_) } ]
  24         41  
162             } (
163 10     10   23 sub { [ $_, $_ ]; },
164 10     10   27 sub { [ $_, 4 - $_ ]; },
165             (
166             map {
167 10         22 my $y = $_;
168 10     50   34 sub { [ $y, $_ ] };
  50         88  
169             } $self->_y_indexes()
170             ),
171             (
172             map {
173 2         22 my $x = $_;
  10         18  
174 10     50   26 sub { [ $_, $x ] };
  50         130  
175             } $self->_x_indexes()
176             ),
177             )
178             ];
179             }
180              
181             my @_clues_positions = @{ __PACKAGE__->_calc_clue_positions() };
182              
183             sub calc_riddle
184             {
185 1     1 1 9 my ($self) = @_;
186              
187 1         4 my $layout = $self->calc_final_layout();
188              
189 1         13 my $A_pos = $layout->get_A_pos;
190              
191             my %init_state = (
192             pos_taken => '',
193 1         4 clues => [ map { +{ num_remaining => 5, } } ( 1 .. $NUM_CLUES ), ]
  12         24  
194             );
195              
196             my $mark = sub {
197 25     25   40 my ( $state, $pos ) = @_;
198              
199 25         64 vec( $state->{pos_taken}, $pos, 1 ) = 1;
200              
201 25         68 my $coord = Games::ABC_Path::Generator::Coord->_from_int($pos);
202              
203 25 100       585 foreach my $clue (
    100          
204             ( ( $coord->y == $coord->x ) ? 0 : () ),
205             ( ( $coord->y == ( 5 - 1 ) - $coord->x ) ? 1 : () ),
206             ( 2 + $coord->y ),
207             ( ( 2 + 5 ) + $coord->x ),
208             )
209             {
210 60         733 $state->{clues}->[$clue]->{num_remaining}--;
211             }
212 1         7 };
213              
214 1         5 $mark->( \%init_state, $A_pos );
215              
216 1         3 my @dfs_stack = ( \%init_state );
217              
218             DFS:
219 1         5 while (@dfs_stack)
220             {
221 13         24 my $last_state = $dfs_stack[-1];
222              
223 13 50       27 if ( !exists( $last_state->{chosen_clue} ) )
224             {
225             my @clues = (
226             sort {
227             ( $a->[1]->{num_remaining} <=> $b->[1]->{num_remaining} )
228 147 50       287 or
229             ( $a->[0] <=> $b->[0] )
230             }
231 156         278 grep { !exists( $_->[1]->{cells} ) }
232 13         32 map { [ $_, $last_state->{clues}->[$_] ] }
  156         284  
233             ( 0 .. $NUM_CLUES - 1 )
234             );
235              
236 13 100       39 if ( !@clues )
237             {
238             # Yay! We found a configuration.
239             my $handle_clue = sub {
240 12     12   16 my @cells = @{ shift->{cells} };
  12         24  
241 24         49 return [ map { $layout->get_cell_contents($_) }
242 12         17 @{ $self->_shuffle( \@cells ) } ];
  12         24  
243 1         5 };
244             my $riddle = Games::ABC_Path::Generator::RiddleObj->new(
245             {
246             solution => $layout,
247             clues => [
248 1         4 map { $handle_clue->($_) } @{ $last_state->{clues} }
  12         29  
  1         4  
249             ],
250             A_pos => Games::ABC_Path::Generator::Coord->_from_int(
251             $A_pos),
252             }
253             );
254              
255 1         9 my $riddle_string = $riddle->get_riddle_v1_string();
256              
257 1         10 my $solver =
258             Games::ABC_Path::Solver::Board->input_from_v1_string(
259             $riddle_string);
260              
261 1         48510 $solver->solve();
262              
263 1 50       823664 if ( @{ $solver->get_successes_text_tables() } != 1 )
  1         6  
264             {
265             # The solution is ambiguous
266 0         0 pop(@dfs_stack);
267 0         0 next DFS;
268             }
269             else
270             {
271 1         17286 return $riddle;
272             }
273             }
274              
275             # Not enough for the clues there.
276 12 50       27 if ( $clues[0][1]->{num_remaining} < 2 )
277             {
278 0         0 pop(@dfs_stack);
279 0         0 next DFS;
280             }
281              
282 12         17 my $clue_idx = $clues[0][0];
283              
284 12         20 $last_state->{chosen_clue} = $clue_idx;
285              
286             my @positions =
287 60         120 ( grep { !vec( $last_state->{pos_taken}, $_, 1 ) }
288 12         19 @{ $_clues_positions[$clue_idx] } );
  12         23  
289              
290 12         18 my @pairs;
291              
292 12         29 foreach my $first_idx ( 0 .. $#positions - 1 )
293             {
294 22         40 foreach my $second_idx ( $first_idx + 1 .. $#positions )
295             {
296 35         77 push @pairs, [ @positions[ $first_idx, $second_idx ] ];
297             }
298             }
299              
300 12         27 $last_state->{pos_pairs} = $self->_shuffle( \@pairs );
301             }
302              
303 12         21 my $chosen_clue = $last_state->{chosen_clue};
304 12         18 my $next_pair = shift( @{ $last_state->{pos_pairs} } );
  12         20  
305              
306 12 50       28 if ( !defined($next_pair) )
307             {
308 0         0 pop(@dfs_stack);
309 0         0 next DFS;
310             }
311              
312 12         17 my %new_state;
313 12         27 $new_state{pos_taken} = $last_state->{pos_taken};
314 12         18 $new_state{clues} = [ map { +{ %{$_} } } @{ $last_state->{clues} } ];
  144         190  
  144         389  
  12         20  
315 12         31 foreach my $pos (@$next_pair)
316             {
317 24         47 $mark->( \%new_state, $pos );
318             }
319 12         25 $new_state{clues}->[$chosen_clue]->{cells} = [@$next_pair];
320              
321 12         52 push @dfs_stack, ( \%new_state );
322             }
323             }
324              
325              
326             1; # End of Games::ABC_Path::Generator
327              
328             __END__