File Coverage

blib/lib/Games/Solitaire/Verify/State.pm
Criterion Covered Total %
statement 285 297 95.9
branch 75 86 87.2
condition n/a
subroutine 54 55 98.1
pod 18 18 100.0
total 432 456 94.7


line stmt bran cond sub pod time code
1             package Games::Solitaire::Verify::State;
2             $Games::Solitaire::Verify::State::VERSION = '0.2402';
3 8     8   232848 use warnings;
  8         45  
  8         278  
4 8     8   45 use strict;
  8         16  
  8         179  
5              
6              
7 8     8   967 use parent 'Games::Solitaire::Verify::Base';
  8         607  
  8         42  
8              
9 8     8   1799 use Games::Solitaire::Verify::Exception ();
  8         21  
  8         183  
10 8     8   1621 use Games::Solitaire::Verify::Card ();
  8         18  
  8         173  
11 8     8   1427 use Games::Solitaire::Verify::Column ();
  8         18  
  8         156  
12 8     8   1378 use Games::Solitaire::Verify::Move ();
  8         20  
  8         161  
13 8     8   3785 use Games::Solitaire::Verify::Freecells ();
  8         24  
  8         196  
14 8     8   3636 use Games::Solitaire::Verify::Foundations ();
  8         22  
  8         198  
15 8     8   2407 use Games::Solitaire::Verify::VariantParams ();
  8         22  
  8         170  
16 8     8   2367 use Games::Solitaire::Verify::VariantsMap ();
  8         26  
  8         242  
17              
18 8     8   54 use List::Util qw(first);
  8         17  
  8         914  
19 8     8   3264 use POSIX qw();
  8         35365  
  8         28000  
20              
21             __PACKAGE__->mk_acc_ref(
22             [
23             qw(
24             _columns
25             _freecells
26             _foundations
27             _variant
28             _variant_params
29             _temp_move
30             )
31             ]
32             );
33              
34              
35             sub set_freecells
36             {
37 274     274 1 610 my ( $self, $freecells ) = @_;
38              
39 274         613 $self->_freecells($freecells);
40              
41 274         469 return;
42             }
43              
44             sub _assign_freecells_from_string
45             {
46 272     272   462 my $self = shift;
47 272         648 my $string = shift;
48              
49 272         670 $self->set_freecells(
50             Games::Solitaire::Verify::Freecells->new(
51             {
52             count => $self->num_freecells(),
53             string => $string,
54             }
55             )
56             );
57              
58 272         619 return;
59             }
60              
61              
62             sub add_column
63             {
64 2246     2246 1 4304 my ( $self, $col ) = @_;
65              
66 2246         3188 push @{ $self->_columns() }, $col;
  2246         5288  
67              
68 2246         5606 return;
69             }
70              
71              
72             sub set_foundations
73             {
74 281     281 1 547 my ( $self, $foundations ) = @_;
75              
76 281         631 $self->_foundations($foundations);
77              
78 281         487 return;
79             }
80              
81             sub _get_suits_seq
82             {
83 0     0   0 my $class = shift;
84              
85 0         0 return Games::Solitaire::Verify::Card->get_suits_seq();
86             }
87              
88             sub _from_string
89             {
90 266     266   591 my ( $self, $str ) = @_;
91              
92 266         489 my $rank_re = '[0A1-9TJQK]';
93              
94 266 50       1408 if ( $str !~ m{\A(Foundations:[^\n]*)\n}gms )
95             {
96 0         0 Games::Solitaire::Verify::Exception::Parse::State::Foundations->throw(
97             error => "Wrong Foundations", );
98             }
99 266         830 my $founds_s = $1;
100              
101 266         715 $self->set_foundations(
102             Games::Solitaire::Verify::Foundations->new(
103             {
104             num_decks => $self->num_decks(),
105             string => $founds_s,
106             }
107             )
108             );
109              
110 266 50       1336 if ( $str !~ m{\G(Freecells:[^\n]*)\n}gms )
111             {
112 0         0 Games::Solitaire::Verify::Exception::Parse::State::Freecells->throw(
113             error => "Wrong Freecell String", );
114             }
115 266         796 $self->_assign_freecells_from_string($1);
116              
117 266         632 foreach my $col_idx ( 0 .. ( $self->num_columns() - 1 ) )
118             {
119 2128 100       9578 if ( $str !~ m{\G(:[^\n]*)\n}msg )
120             {
121 2         32 Games::Solitaire::Verify::Exception::Parse::State::Column->throw(
122             error => "Cannot parse column",
123             index => $col_idx,
124             );
125             }
126 2126         5376 my $column_str = $1;
127              
128 2126         7194 $self->add_column(
129             Games::Solitaire::Verify::Column->new(
130             {
131             string => $column_str,
132             }
133             )
134             );
135             }
136              
137 264         833 return;
138             }
139              
140             sub _fill_non_custom_variant
141             {
142 272     272   411 my $self = shift;
143 272         470 my $variant = shift;
144              
145 272         815 my $variants_map = Games::Solitaire::Verify::VariantsMap->new();
146              
147 272         771 my $params = $variants_map->get_variant_by_id($variant);
148              
149 272 50       700 if ( !defined($params) )
150             {
151 0         0 Games::Solitaire::Verify::Exception::Variant::Unknown->throw(
152             error => "Unknown/Unsupported Variant",
153             variant => $variant,
154             );
155             }
156 272         594 $self->_variant_params($params);
157 272         683 $self->_variant($variant);
158              
159 272         988 return;
160             }
161              
162             sub _set_variant
163             {
164 281     281   466 my $self = shift;
165 281         455 my $args = shift;
166              
167 281         522 my $variant = $args->{variant};
168              
169 281 100       902 if ( $variant eq "custom" )
170             {
171 9         42 $self->_variant($variant);
172 9         45 $self->_variant_params( $args->{variant_params} );
173             }
174             else
175             {
176 272         593 $self->_fill_non_custom_variant($variant);
177             }
178              
179 281         479 return;
180             }
181              
182             sub _init
183             {
184 281     281   574 my ( $self, $args ) = @_;
185              
186             # Set the variant
187 281         891 $self->_set_variant($args);
188              
189 281         635 $self->_columns( [] );
190              
191 281 100       717 if ( exists( $args->{string} ) )
192             {
193 272         694 return $self->_from_string( $args->{string} );
194             }
195 9         22 return;
196             }
197              
198              
199             sub get_freecell
200             {
201 1939     1939 1 3579 my ( $self, $index ) = @_;
202              
203 1939         5186 return $self->_freecells()->cell($index);
204             }
205              
206              
207             sub set_freecell
208             {
209 590     590 1 1318 my ( $self, $index, $card ) = @_;
210              
211 590         1630 return $self->_freecells->assign( $index, $card );
212             }
213              
214              
215             sub get_foundation_value
216             {
217 866     866 1 1890 my ( $self, $suit, $idx ) = @_;
218              
219 866         2542 return $self->_foundations()->value( $suit, $idx );
220             }
221              
222              
223             sub increment_foundation_value
224             {
225 833     833 1 1634 my ( $self, $suit, $idx ) = @_;
226              
227 833         2611 $self->_foundations()->increment( $suit, $idx );
228              
229 833         1206 return;
230             }
231              
232              
233             sub num_decks
234             {
235 1066     1066 1 1947 my $self = shift;
236              
237 1066         5017 return $self->_variant_params->num_decks();
238             }
239              
240              
241             sub num_freecells
242             {
243 487     487 1 824 my $self = shift;
244              
245 487         2820 return $self->_variant_params->num_freecells();
246             }
247              
248              
249             sub num_empty_freecells
250             {
251 489     489 1 743 my $self = shift;
252              
253 489         1433 return $self->_freecells->num_empty();
254             }
255              
256              
257             sub num_columns
258             {
259 1168     1168 1 2044 my $self = shift;
260              
261 1168         4308 return $self->_variant_params->num_columns();
262             }
263              
264              
265             sub get_column
266             {
267 13203     13203 1 20155 my $self = shift;
268 13203         18998 my $index = shift;
269              
270 13203         32616 return $self->_columns->[$index];
271             }
272              
273              
274             sub num_empty_columns
275             {
276 452     452 1 758 my $self = shift;
277              
278 452         730 my $count = 0;
279              
280 452         887 foreach my $idx ( 0 .. ( $self->num_columns() - 1 ) )
281             {
282 3776 100       6320 if ( !$self->get_column($idx)->len() )
283             {
284 328         558 ++$count;
285             }
286             }
287 452         1522 return $count;
288             }
289              
290              
291             sub clone
292             {
293 7     7 1 46 my $self = shift;
294              
295 7         18 my $variant = $self->_variant;
296 7 100       38 my $copy = Games::Solitaire::Verify::State->new(
297             {
298             variant => $variant,
299             (
300             ( $variant eq "custom" )
301             ? ( variant_params => $self->_variant_params() )
302             : ()
303             ),
304             }
305             );
306              
307 7         27 foreach my $idx ( 0 .. ( $self->num_columns() - 1 ) )
308             {
309 56         122 $copy->add_column( $self->get_column($idx)->clone() );
310             }
311              
312 7         62 $copy->set_foundations( $self->_foundations()->clone() );
313              
314 7         32 $copy->_freecells( $self->_freecells()->clone() );
315              
316 7         26 return $copy;
317             }
318              
319              
320             # Returns 0 on success, else the error.
321             sub _can_put_into_empty_column
322             {
323 225     225   529 my ( $self, $card ) = @_;
324              
325 225 100       740 if ( $self->_variant_params->empty_stacks_filled_by() eq "kings" )
326             {
327 13 100       56 if ( $card->rank() != 13 )
328             {
329             return
330 2         58 Games::Solitaire::Verify::Exception::Move::Dest::Col::OnlyKingsCanFillEmpty
331             ->new(
332             error => "Non-king on an empty stack",
333             move => $self->_temp_move(),
334             );
335             }
336             }
337 223         610 return 0;
338             }
339              
340             sub _is_matching_color
341             {
342 1422     1422   2410 my ( $self, $parent, $child ) = @_;
343              
344 1422         3010 my $rules = $self->_variant_params()->rules();
345 1422         2788 my $sbb = $self->_variant_params()->seq_build_by();
346              
347 1422 50       4520 my $verdict = (
    100          
    100          
348             ( $rules eq "simple_simon" ) ? 0
349             : ( $sbb eq "alt_color" ) ? ( $parent->color() eq $child->color() )
350             : ( $sbb eq "suit" ) ? ( $parent->suit() ne $child->suit() )
351             : 0
352             );
353              
354 1422 100       3196 if ($verdict)
355             {
356             return
357 3         67 Games::Solitaire::Verify::Exception::Move::Dest::Col::NonMatchSuits
358             ->new(
359             seq_build_by => $sbb,
360             move => $self->_temp_move(),
361             );
362             }
363              
364 1419         3281 return 0;
365             }
366              
367             sub _can_put_on_top
368             {
369 1425     1425   2603 my ( $self, $parent, $child ) = @_;
370              
371 1425 100       3861 if ( $parent->rank() != $child->rank() + 1 )
372             {
373             return
374 3         63 Games::Solitaire::Verify::Exception::Move::Dest::Col::RankMismatch
375             ->new(
376             error => "Rank mismatch between parent and child cards",
377             move => $self->_temp_move(),
378             );
379             }
380              
381 1422 100       2876 if ( my $ret = $self->_is_matching_color( $parent, $child ) )
382             {
383 3         13 return $ret;
384             }
385              
386 1419         3445 return 0;
387             }
388              
389             sub _can_put_on_column
390             {
391 1088     1088   2196 my ( $self, $col_idx, $card ) = @_;
392              
393             return (
394 1088 100       2248 ( $self->get_column($col_idx)->len() == 0 )
395             ? $self->_can_put_into_empty_column($card)
396             : $self->_can_put_on_top( $self->get_column($col_idx)->top(), $card )
397             );
398             }
399              
400             sub _calc_freecell_max_seq_move
401             {
402 451     451   792 my ( $self, $args ) = @_;
403 451 50       1078 my $to_empty = ( defined( $args->{to_empty} ) ? $args->{to_empty} : 0 );
404              
405 451         948 return ( ( $self->num_empty_freecells() + 1 )
406             << ( $self->num_empty_columns() - $to_empty ) );
407             }
408              
409             sub _calc_empty_stacks_filled_by_any_card_max_seq_move
410             {
411 451     451   950 my ( $self, $args ) = @_;
412              
413 451         952 return $self->_calc_freecell_max_seq_move($args);
414             }
415              
416             sub _calc_max_sequence_move
417             {
418 615     615   1224 my ( $self, $args ) = @_;
419              
420 615 100       2588 return +( $self->_variant_params->sequence_move() eq "unlimited" )
    100          
421             ? POSIX::INT_MAX()
422             : ( $self->_variant_params->empty_stacks_filled_by() eq "any" )
423             ? $self->_calc_empty_stacks_filled_by_any_card_max_seq_move($args)
424             : ( $self->num_empty_freecells() + 1 );
425             }
426              
427             sub _is_sequence_in_column
428             {
429 625     625   1413 my ( $self, $source_idx, $num_cards, $num_seq_components_ref ) = @_;
430              
431 625         1196 my $col = $self->get_column($source_idx);
432 625         1337 my $len = $col->len();
433              
434 625         1568 my $rules = $self->_variant_params()->rules();
435              
436 625         973 my $num_comps = 1;
437              
438 625         1784 foreach my $card_idx ( 0 .. ( $num_cards - 2 ) )
439             {
440 562         1412 my $parent = $col->pos( $len - 1 - $card_idx - 1 );
441 562         1215 my $child = $col->pos( $len - 1 - $card_idx );
442              
443 562 100       1148 if ( $self->_can_put_on_top( $parent, $child ) )
444             {
445             return
446 1         31 Games::Solitaire::Verify::Exception::Move::Src::Col::NonSequence
447             ->new(
448             move => $self->_temp_move(),
449             pos => $card_idx,
450             );
451             }
452              
453             $num_comps += (
454 561 100       1457 ( $rules eq "simple_simon" )
    100          
455             ? ( ( $parent->suit() ne $child->suit() ) ? 1 : 0 )
456             : 1
457             );
458             }
459              
460 624         982 ${$num_seq_components_ref} = $num_comps;
  624         1037  
461              
462 624         1638 return 0;
463             }
464              
465              
466             sub clear_freecell
467             {
468 578     578 1 1213 my ( $self, $index ) = @_;
469              
470 578         1765 return $self->_freecells->clear($index);
471             }
472              
473             sub verify_and_perform_move
474             {
475 2458     2458 1 12989 my ( $self, $move ) = @_;
476              
477 2458 50       11845 if ( my $method =
478             $self->can( "_mv_" . $move->source_type . "_to_" . $move->dest_type ) )
479             {
480 2458         5425 $self->_temp_move($move);
481 2458         4783 my $ret = $method->($self);
482 2458         13271 $self->_temp_move( undef() );
483 2458         7824 return $ret;
484             }
485             else
486             {
487 0         0 die "Cannot handle this move type";
488             }
489             }
490              
491             sub _mv_stack_to_foundation
492             {
493 657     657   1074 my $self = shift;
494              
495 657         1144 my $move = $self->_temp_move();
496              
497 657         1250 my $col_idx = $move->source();
498 657         1374 my $card = $self->get_column($col_idx)->top();
499              
500 657         1480 my $rank = $card->rank();
501 657         1298 my $suit = $card->suit();
502              
503 657     657   1620 my $f_idx = first { $self->get_foundation_value( $suit, $_ ) == $rank - 1 }
504 657         3442 ( 0 .. ( $self->num_decks() - 1 ) );
505              
506 657 100       2501 if ( defined($f_idx) )
507             {
508 656         1458 $self->get_column($col_idx)->pop();
509 656         1760 $self->increment_foundation_value( $suit, $f_idx );
510 656         2159 return 0;
511             }
512             else
513             {
514             return
515 1         9 Games::Solitaire::Verify::Exception::Move::Dest::Foundation->new(
516             move => $move );
517             }
518             }
519              
520             sub _mv_stack_seq_to_foundation
521             {
522 7     7   15 my $self = shift;
523              
524 7         18 my $move = $self->_temp_move();
525              
526 7         24 my $rules = $self->_variant_params()->rules();
527              
528 7 100       24 if ( $rules ne "simple_simon" )
529             {
530 1         19 return Games::Solitaire::Verify::Exception::Move::Variant::Unsupported
531             ->new( move => $move );
532             }
533              
534 6         29 my $col_idx = $move->source();
535              
536 6         12 my $num_seq_components;
537 6         18 my $verdict =
538             $self->_is_sequence_in_column( $col_idx, 13, \$num_seq_components, );
539              
540 6 50       32 if ($verdict)
541             {
542 0         0 return $verdict;
543             }
544              
545 6 100       16 if ( $num_seq_components != 1 )
546             {
547 1         26 return Games::Solitaire::Verify::Exception::Move::Src::Col::NotTrueSeq
548             ->new( move => $move );
549             }
550              
551 5         15 my $card = $self->get_column($col_idx)->top();
552              
553 5         14 my $suit = $card->suit();
554              
555 5     5   28 my $f_idx = first { $self->get_foundation_value( $suit, $_ ) == 0 }
556 5         36 ( 0 .. ( $self->num_decks() - 1 ) );
557              
558 5 50       29 if ( defined($f_idx) )
559             {
560 5         17 foreach my $card_idx ( 1 .. 13 )
561             {
562 65         114 $self->get_column($col_idx)->pop();
563 65         130 $self->increment_foundation_value( $suit, $f_idx );
564             }
565 5         18 return 0;
566             }
567             else
568             {
569             return
570 0         0 Games::Solitaire::Verify::Exception::Move::Dest::Foundation->new(
571             move => $move );
572             }
573             }
574              
575             sub _mv_stack_to_freecell
576             {
577 589     589   938 my $self = shift;
578 589         1146 my $move = $self->_temp_move();
579              
580 589         1155 my $col_idx = $move->source();
581 589         1128 my $fc_idx = $move->dest();
582              
583 589 100       1345 if ( !$self->get_column($col_idx)->len() )
584             {
585             return
586 1         21 Games::Solitaire::Verify::Exception::Move::Src::Col::NoCards->new(
587             move => $move, );
588             }
589              
590 588 100       1351 if ( defined( $self->get_freecell($fc_idx) ) )
591             {
592 1         26 return Games::Solitaire::Verify::Exception::Move::Dest::Freecell->new(
593             move => $move, );
594             }
595              
596 587         1229 $self->set_freecell( $fc_idx, $self->get_column($col_idx)->pop() );
597              
598 587         1209 return 0;
599             }
600              
601             sub _mv_stack_to_stack
602             {
603 620     620   1004 my $self = shift;
604 620         1139 my $move = $self->_temp_move();
605              
606 620         1218 my $source = $move->source();
607 620         1158 my $dest = $move->dest();
608 620         1037 my $num_cards = $move->num_cards();
609              
610             # Source column
611 620         1285 my $sc = $self->get_column($source);
612 620         1488 my $dc = $self->get_column($dest);
613              
614 620         1626 my $source_len = $sc->len();
615              
616 620 100       1483 if ( $source_len < $num_cards )
617             {
618             return
619 1         19 Games::Solitaire::Verify::Exception::Move::Src::Col::NotEnoughCards
620             ->new( move => $move, );
621             }
622              
623 619         970 my $num_seq_components;
624 619 100       1532 if (
625             my $verdict = $self->_is_sequence_in_column(
626             $source, $num_cards, \$num_seq_components,
627             )
628             )
629             {
630 1         19 return $verdict;
631             }
632              
633 618 100       1761 if (
634             my $verdict = $self->_can_put_on_column(
635             $dest, $sc->pos( $source_len - $num_cards )
636             )
637             )
638             {
639 3         9 return $verdict;
640             }
641              
642             # Now let's see if we have enough resources
643             # to move the cards.
644              
645 615 100       1671 if (
646             $num_seq_components > $self->_calc_max_sequence_move(
647             {
648             to_empty => ( $dc->len() == 0 ),
649             }
650             )
651             )
652             {
653             return
654 3         66 Games::Solitaire::Verify::Exception::Move::NotEnoughEmpties->new(
655             move => $move, );
656             }
657              
658             # Now let's actually move them.
659 612         1950 $dc->append_cards( $sc->popN($num_cards) );
660              
661 612         1496 return 0;
662             }
663              
664             sub _mv_freecell_to_foundation
665             {
666 114     114   199 my $self = shift;
667 114         234 my $move = $self->_temp_move();
668              
669 114         229 my $fc_idx = $move->source();
670 114         283 my $card = $self->get_freecell($fc_idx);
671              
672 114 100       303 if ( !defined($card) )
673             {
674             return
675 1         5 Games::Solitaire::Verify::Exception::Move::Src::Freecell::Empty
676             ->new( move => $move, );
677             }
678              
679 113         250 my $rank = $card->rank();
680 113         258 my $suit = $card->suit();
681              
682 113     113   278 my $f_idx = first { $self->get_foundation_value( $suit, $_ ) == $rank - 1 }
683 113         636 ( 0 .. ( $self->num_decks() - 1 ) );
684              
685 113 100       437 if ( defined($f_idx) )
686             {
687 112         354 $self->clear_freecell($fc_idx);
688 112         320 $self->increment_foundation_value( $suit, $f_idx );
689 112         404 return 0;
690             }
691             else
692             {
693             return
694 1         20 Games::Solitaire::Verify::Exception::Move::Dest::Foundation->new(
695             move => $move );
696             }
697             }
698              
699             sub _mv_freecell_to_stack
700             {
701 471     471   799 my $self = shift;
702 471         858 my $move = $self->_temp_move();
703              
704 471         908 my $fc_idx = $move->source();
705 471         856 my $col_idx = $move->dest();
706              
707 471         1129 my $card = $self->get_freecell($fc_idx);
708              
709 471 100       1188 if ( !defined($card) )
710             {
711 1         24 return Games::Solitaire::Verify::Exception::Move::Src::Freecell::Empty
712             ->new( move => $move, );
713             }
714              
715 470 100       1075 if ( my $verdict = $self->_can_put_on_column( $col_idx, $card ) )
716             {
717 4         14 return $verdict;
718             }
719              
720 466         998 $self->get_column($col_idx)->push($card);
721 466         1315 $self->clear_freecell($fc_idx);
722              
723 466         910 return 0;
724             }
725              
726              
727             my @SS = ( @{ Games::Solitaire::Verify::Card->get_suits_seq() } );
728              
729             sub verify_contents
730             {
731 16     16 1 49 my ( $self, $args ) = @_;
732              
733 16         35 my $MAX_RANK = $args->{max_rank};
734 16         35 my $found = {};
735             my $register = sub {
736 832     832   1154 my $card = shift;
737 832 50       1703 if ( $card->rank > $MAX_RANK )
738             {
739 0         0 die Games::Solitaire::Verify::Exception::State::TooHighRank->new(
740             cards => [$card], );
741             }
742 832         1512 my $s = $card->fast_s;
743 832 50       2416 if ( ( ++$found->{$s} ) > 1 )
744             {
745 0         0 die Games::Solitaire::Verify::Exception::State::ExtraCards->new(
746             cards => [$card], );
747             }
748 832         1491 return;
749 16         128 };
750 16         61 for my $fc ( 0 .. $self->num_freecells - 1 )
751             {
752 64         137 my $card = $self->get_freecell($fc);
753 64 100       159 if ( defined $card )
754             {
755 14         30 $register->($card);
756             }
757             }
758 16         48 foreach my $suit (@SS)
759             {
760 64         137 for my $rank ( 1 .. $self->get_foundation_value( $suit, 0 ) )
761             {
762 0         0 $register->(
763             Games::Solitaire::Verify::Card->new(
764             {
765             string => (
766             Games::Solitaire::Verify::Card->rank_to_string(
767             $rank)
768             . $suit
769             )
770             }
771             ),
772             );
773             }
774             }
775              
776 16         48 foreach my $idx ( 0 .. ( $self->num_columns() - 1 ) )
777             {
778 132         267 my $col = $self->get_column($idx);
779 132         306 for my $pos ( 0 .. $col->len - 1 )
780             {
781 818         1672 $register->( $col->pos($pos) );
782             }
783             }
784              
785 16 50       92 if ( scalar( keys %$found ) != $MAX_RANK * 4 )
786             {
787 0         0 die Games::Solitaire::Verify::Exception::State::MissingCards->new(
788             cards => [], );
789             }
790              
791 16         215 return;
792             }
793              
794              
795             sub to_string
796             {
797 2226     2226 1 3616 my $self = shift;
798              
799             return join(
800             "\n",
801             (
802 22606         45007 map { $_->to_string() } $self->_foundations(),
803             $self->_freecells(),
804 2226         4605 @{ $self->_columns() }
  2226         4613  
805             ),
806             ""
807             );
808             }
809              
810             1; # End of Games::Solitaire::Verify::State
811              
812             __END__