File Coverage

blib/lib/Games/Solitaire/Verify/FromOtherSolversBase.pm
Criterion Covered Total %
statement 90 124 72.5
branch 12 24 50.0
condition 0 3 0.0
subroutine 25 32 78.1
pod 1 1 100.0
total 128 184 69.5


line stmt bran cond sub pod time code
1             package Games::Solitaire::Verify::FromOtherSolversBase;
2             $Games::Solitaire::Verify::FromOtherSolversBase::VERSION = '0.2402';
3 2     2   1145 use strict;
  2         5  
  2         64  
4 2     2   15 use warnings;
  2         5  
  2         50  
5 2     2   10 use autodie;
  2         5  
  2         9  
6              
7 2     2   10767 use List::Util qw(first);
  2         5  
  2         262  
8 2     2   16 use Path::Tiny qw/ path /;
  2         4  
  2         117  
9              
10 2     2   14 use parent 'Games::Solitaire::Verify::Base';
  2         4  
  2         17  
11              
12 2     2   1090 use Games::Solitaire::Verify::VariantsMap ();
  2         10  
  2         63  
13 2     2   1163 use Games::Solitaire::Verify::Solution ();
  2         7  
  2         58  
14 2     2   1216 use Games::Solitaire::Verify::State::LaxParser ();
  2         7  
  2         44  
15 2     2   14 use Games::Solitaire::Verify::Move ();
  2         6  
  2         48  
16              
17 2     2   1569 use Getopt::Long qw(GetOptionsFromArray);
  2         21869  
  2         11  
18              
19             sub _init
20             {
21 4     4   15 my ( $self, $args ) = @_;
22              
23 4         13 my $argv = $args->{'argv'};
24              
25 4         49 my $variant_map = Games::Solitaire::Verify::VariantsMap->new();
26              
27 4         18 my $variant_params = $variant_map->get_variant_by_id("freecell");
28              
29             GetOptionsFromArray(
30             $argv,
31             'g|game|variant=s' => sub {
32 4     4   3169 my ( undef, $game ) = @_;
33              
34 4         16 $variant_params = $variant_map->get_variant_by_id($game);
35              
36 4 50       20 if ( !defined($variant_params) )
37             {
38 0         0 die "Unknown variant '$game'!\n";
39             }
40             },
41             'freecells-num=i' => sub {
42 0     0   0 my ( undef, $n ) = @_;
43 0         0 $variant_params->num_freecells($n);
44             },
45             'stacks-num=i' => sub {
46 0     0   0 my ( undef, $n ) = @_;
47 0         0 $variant_params->num_columns($n);
48             },
49             'decks-num=i' => sub {
50 0     0   0 my ( undef, $n ) = @_;
51              
52 0 0 0     0 if ( !( ( $n == 1 ) || ( $n == 2 ) ) )
53             {
54 0         0 die "Decks should be 1 or 2.";
55             }
56              
57 0         0 $variant_params->num_decks($n);
58             },
59             'sequences-are-built-by=s' => sub {
60 0     0   0 my ( undef, $val ) = @_;
61              
62             my %seqs_build_by = (
63 0         0 ( map { $_ => $_ } (qw(alt_color suit rank)) ),
  0         0  
64             "alternate_color" => "alt_color",
65             );
66              
67 0         0 my $proc_val = $seqs_build_by{$val};
68              
69 0 0       0 if ( !defined($proc_val) )
70             {
71 0         0 die "Unknown sequences-are-built-by '$val'!";
72             }
73              
74 0         0 $variant_params->seqs_build_by($proc_val);
75             },
76             'empty-stacks-filled-by=s' => sub {
77 0     0   0 my ( undef, $val ) = @_;
78              
79             my %empty_stacks_filled_by_map =
80 0         0 ( map { $_ => 1 } (qw(kings any none)) );
  0         0  
81              
82 0 0       0 if ( !exists( $empty_stacks_filled_by_map{$val} ) )
83             {
84 0         0 die "Unknown empty stacks filled by '$val'!";
85             }
86              
87 0         0 $variant_params->empty_stacks_filled_by($val);
88             },
89             'sequence-move=s' => sub {
90 0     0   0 my ( undef, $val ) = @_;
91              
92 0         0 my %seq_moves = ( map { $_ => 1 } (qw(limited unlimited)) );
  0         0  
93              
94 0 0       0 if ( !exists( $seq_moves{$val} ) )
95             {
96 0         0 die "Unknown sequence move '$val'!";
97             }
98              
99 0         0 $variant_params->sequence_move($val);
100             },
101 4 50       93 ) or die "Cannot process command line arguments";
102              
103 4         547 my $filename = shift(@$argv);
104              
105 4 50       13 if ( !defined($filename) )
106             {
107 0         0 $filename = "-";
108             }
109              
110 4         12 my $sol_filename = shift(@$argv);
111              
112 4 50       11 if ( !defined($sol_filename) )
113             {
114 0         0 die "Solution filename not specified.";
115             }
116              
117 4         19 $self->_variant_params($variant_params);
118 4         20 $self->_filename($filename);
119 4         25 $self->_sol_filename($sol_filename);
120              
121 4         11 my $s = '';
122 4         16 $self->_buffer_ref( \$s );
123              
124 4         21 return;
125             }
126              
127             sub _append
128             {
129 643     643   1286 my ( $self, $text ) = @_;
130              
131 643         989 ${ $self->_buffer_ref } .= $text;
  643         2016  
132              
133 643         1205 return;
134             }
135              
136             sub _get_buffer
137             {
138 6     6   59 my ($self) = @_;
139              
140 6         11 return ${ $self->_buffer_ref };
  6         141  
141             }
142              
143             sub _read_initial_state
144             {
145 4     4   15 my $self = shift;
146              
147 4         20 $self->_st(
148             Games::Solitaire::Verify::State::LaxParser->new(
149             {
150             string => path( $self->_filename )->slurp_raw,
151             variant => 'custom',
152             'variant_params' => $self->_variant_params(),
153             }
154             )
155             );
156              
157 4         38 $self->_append("-=-=-=-=-=-=-=-=-=-=-=-\n\n");
158              
159 4         24 $self->_out_running_state;
160              
161 4         11 return;
162             }
163              
164             sub _out_running_state
165             {
166 320     320   592 my ($self) = @_;
167              
168 320         931 $self->_append( $self->_st->to_string() . "\n\n====================\n\n" );
169              
170 320         583 return;
171             }
172              
173             sub _perform_and_output_move
174             {
175 316     316   658 my ( $self, $move_s ) = @_;
176              
177 316         981 $self->_append("$move_s\n\n");
178              
179 316         1697 $self->_st->verify_and_perform_move(
180             Games::Solitaire::Verify::Move->new(
181             {
182             fcs_string => $move_s,
183             game => $self->_st->_variant(),
184             },
185             )
186             );
187 316         1305 $self->_out_running_state;
188              
189 316         1129 return;
190             }
191              
192             sub _find_col_card
193             {
194 327     327   994 my ( $self, $card_s ) = @_;
195              
196             return first
197             {
198 1725     1725   4207 my $col = $self->_st->get_column($_);
199 1725 100       3566 ( $col->len == 0 ) ? 0 : $col->top->fast_s eq $card_s
200             }
201 327         1736 ( 0 .. $self->_st->num_columns - 1 );
202             }
203              
204             sub _find_empty_col
205             {
206 11     11   19 my ($self) = @_;
207              
208             return first
209             {
210 42     42   102 $self->_st->get_column($_)->len == 0
211             }
212 11         64 ( 0 .. $self->_st->num_columns - 1 );
213             }
214              
215             sub _find_fc_card
216             {
217 85     85   198 my ( $self, $card_s ) = @_;
218             return first
219             {
220 276     276   646 my $card = $self->_st->get_freecell($_);
221 276 100       684 defined($card) ? ( $card->fast_s eq $card_s ) : 0;
222             }
223 85         402 ( 0 .. $self->_st->num_freecells - 1 );
224             }
225              
226             sub _find_card_src_string
227             {
228 245     245   496 my ( $self, $src_card_s ) = @_;
229              
230 245         499 my $src_col_idx = $self->_find_col_card($src_card_s);
231              
232 245 100       928 if ( not defined $src_col_idx )
233             {
234 85         206 my $src_fc_idx = $self->_find_fc_card($src_card_s);
235 85 100       313 if ( not defined($src_fc_idx) )
236             {
237 43         362 die "Cannot find card <$src_card_s>.";
238             }
239 42         173 return ( "a card", "freecell $src_fc_idx" );
240             }
241             else
242             {
243 160         628 return ( "1 cards", "stack $src_col_idx" );
244             }
245             }
246              
247             sub run
248             {
249 0     0 1   my ($self) = @_;
250              
251 0           $self->_process_main;
252              
253 0           print $self->_get_buffer;
254              
255 0           return;
256             }
257              
258             1;
259              
260             __END__