File Coverage

lib/Games/Checkers/MoveLocationConstructor.pm
Criterion Covered Total %
statement 21 93 22.5
branch 0 30 0.0
condition 0 39 0.0
subroutine 7 18 38.8
pod 0 11 0.0
total 28 191 14.6


line stmt bran cond sub pod time code
1             # Games::Checkers, Copyright (C) 1996-2012 Mikhael Goikhman, migo@cpan.org
2             #
3             # This program is free software: you can redistribute it and/or modify
4             # it under the terms of the GNU General Public License as published by
5             # the Free Software Foundation, either version 3 of the License, or
6             # (at your option) any later version.
7             #
8             # This program is distributed in the hope that it will be useful,
9             # but WITHOUT ANY WARRANTY; without even the implied warranty of
10             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11             # GNU General Public License for more details.
12             #
13             # You should have received a copy of the GNU General Public License
14             # along with this program. If not, see .
15              
16 1     1   6 use strict;
  1         2  
  1         28  
17 1     1   5 use warnings;
  1         2  
  1         29  
18              
19             package Games::Checkers::MoveLocationConstructor;
20              
21 1     1   4 use base 'Games::Checkers::Board';
  1         1  
  1         89  
22 1     1   7 use Games::Checkers::Constants;
  1         20  
  1         7  
23 1     1   6 use Games::Checkers::BoardConstants;
  1         2  
  1         6  
24 1     1   4 use Games::Checkers::MoveConstants;
  1         2  
  1         6  
25              
26 1     1   5 use constant MAX_MOVE_JUMP_NUM => 9;
  1         1  
  1         983  
27              
28             sub new ($$$) {
29 0     0 0   my $class = shift;
30 0           my $board = shift;
31 0           my $color = shift;
32              
33 0           my $self = $class->SUPER::new($board);
34 0           my $fields = {
35             color => $color,
36             destin => [],
37             src => NL,
38             piece => 0,
39             must_beat => $board->can_color_beat($color),
40             orig_board => $board,
41             };
42 0           $self->{$_} = $fields->{$_} foreach keys %$fields;
43 0           return $self;
44             }
45            
46             sub init ($) {
47 0     0 0   my $self = shift;
48 0           $self->{destin} = [];
49 0           $self->{src} = NL;
50 0           $self->copy($self->{orig_board});
51             }
52              
53             sub source ($$) {
54 0     0 0   my $self = shift;
55 0           my $loc = shift;
56 0           $self->init;
57 0 0 0       return Err if $loc == NL || !$self->occup($loc) || $self->color($loc) != $self->{color};
      0        
58 0 0 0       return Err if $self->{must_beat} && !$self->can_piece_beat($loc) || !$self->{must_beat} && !$self->can_piece_step($loc);
      0        
      0        
59 0           $self->{piece} = $self->piece($self->{src} = $loc);
60 0           return Ok;
61             }
62              
63             sub add_dst ($$) {
64 0     0 0   my $self = shift;
65 0           my $dst = shift;
66 0 0 0       return Err if $self->{src} == NL || @{$self->{destin}} == MAX_MOVE_JUMP_NUM-1;
  0            
67 0 0         if ($self->{must_beat}) {
68 0 0         die "Internal" unless $self->occup($self->dst_1);
69 0 0         return Err unless $self->can_piece_beat($self->dst_1, $dst);
70             } else {
71 0 0         return Err if @{$self->{destin}} > 0;
  0            
72 0 0         return Err unless $self->can_piece_step($self->{src}, $dst);
73             }
74 0           push @{$self->{destin}}, $dst;
  0            
75 0           $self->transform_one;
76 0           return Ok;
77             }
78              
79             sub del_dst ($) {
80 0     0 0   my $self = shift;
81 0 0 0       return NL if $self->{src} == NL || @{$self->{destin}} == 0;
  0            
82 0           my $dst = pop @{$self->{destin}};
  0            
83 0           $self->transform_all;
84 0           return $dst;
85             }
86              
87             sub can_create_move ($) {
88 0     0 0   my $self = shift;
89             return $self->{must_beat} && @{$self->{destin}} > 0
90             && $self->can_piece_beat($self->dst_1) == No
91 0   0       || !$self->{must_beat} && @{$self->{destin}} == 1;
92             }
93              
94             sub create_move ($) {
95 0     0 0   my $self = shift;
96 0           return NO_MOVE if $self->{src} == NL
97 0           || $self->{must_beat} && @{$self->{destin}} < 1
98 0 0 0       || !$self->{must_beat} && @{$self->{destin}} != 1;
      0        
      0        
      0        
99 0           return new Games::Checkers::Move(
100             $self->{must_beat}, $self->{src}, $self->{destin});
101             }
102              
103             sub transform_one ($) {
104 0     0 0   my $self = shift;
105 0           my $src = $self->dst_2;
106 0           my $dst = $self->dst_1;
107 0           $self->clr($src);
108 0           $self->set($dst, $self->{color}, $self->{piece});
109 0 0         $self->clr($self->figure_between($src, $dst)) if $self->{must_beat};
110 0 0         if (convert_type->[$self->{color}][$self->{piece}] & (1 << $dst)) {
111 0           $self->{piece_map} ^= (1 << $dst);
112 0           $self->{piece} ^= 1;
113             }
114             }
115              
116             sub transform_all ($) {
117 0     0 0   my $self = shift;
118 0           $self->copy($self->{orig_board});
119 0 0 0       return if $self->{src} == NL || @{$self->{destin}} == 0;
  0            
120 0           $self->{piece} = $self->piece($self->{src});
121 0           my $destin = $self->{destin};
122 0           $self->{destin} = [];
123 0           while (@$destin) {
124 0           push @{$self->{destin}}, shift @$destin;
  0            
125 0           $self->transform_one;
126             }
127             }
128              
129             sub dst_1 ($) {
130 0     0 0   my $self = shift;
131 0 0         return @{$self->{destin}} == 0 ? $self->{src} : $self->{destin}->[-1];
  0            
132             }
133              
134             sub dst_2 ($) {
135 0     0 0   my $self = shift;
136 0 0         return @{$self->{destin}} == 1 ? $self->{src} : $self->{destin}->[-2];
  0            
137             }
138              
139             1;