File Coverage

blib/lib/Games/LMSolve/Tilt/RedBlue.pm
Criterion Covered Total %
statement 15 74 20.2
branch 0 8 0.0
condition 0 15 0.0
subroutine 5 13 38.4
pod 8 8 100.0
total 28 118 23.7


line stmt bran cond sub pod time code
1             package Games::LMSolve::Tilt::RedBlue;
2             $Games::LMSolve::Tilt::RedBlue::VERSION = '0.14.2';
3 1     1   856 use strict;
  1         2  
  1         26  
4 1     1   4 use warnings;
  1         2  
  1         21  
5              
6 1     1   5 use Games::LMSolve::Tilt::Base;
  1         2  
  1         28  
7              
8 1     1   5 use Games::LMSolve::Input;
  1         3  
  1         27  
9              
10 1     1   6 use vars qw(@ISA);
  1         2  
  1         669  
11              
12             @ISA = qw(Games::LMSolve::Tilt::Base);
13              
14             sub input_board
15             {
16 0     0 1   my $self = shift;
17 0           my $filename = shift;
18              
19 0           my $spec = {
20             'dims' => { 'type' => "xy(integer)", 'required' => 1 },
21             'red_start' => { 'type' => "xy(integer)", 'required' => 1 },
22             'red_goal' => { 'type' => "xy(integer)", 'required' => 1 },
23             'blue_start' => { 'type' => "xy(integer)", 'required' => 1 },
24             'blue_goal' => { 'type' => "xy(integer)", 'required' => 1 },
25             'layout' => { 'type' => "layout", 'required' => 1 },
26             };
27              
28 0           my $input_obj = Games::LMSolve::Input->new();
29              
30 0           my $input_fields = $input_obj->input_board( $filename, $spec );
31              
32             my ( $width, $height ) =
33 0           @{ $input_fields->{'dims'}->{'value'} }{ 'x', 'y' };
  0            
34             my ( $red_start_x, $red_start_y ) =
35 0           @{ $input_fields->{'red_start'}->{'value'} }{ 'x', 'y' };
  0            
36             my ( $red_goal_x, $red_goal_y ) =
37 0           @{ $input_fields->{'red_goal'}->{'value'} }{ 'x', 'y' };
  0            
38             my ( $blue_start_x, $blue_start_y ) =
39 0           @{ $input_fields->{'blue_start'}->{'value'} }{ 'x', 'y' };
  0            
40             my ( $blue_goal_x, $blue_goal_y ) =
41 0           @{ $input_fields->{'blue_goal'}->{'value'} }{ 'x', 'y' };
  0            
42              
43 0 0 0       if ( ( $red_start_x >= $width ) || ( $red_start_y >= $height ) )
44             {
45 0           die
46             "The starting position of the red block is out of bounds of the board in file \"$filename\"!\n";
47             }
48              
49 0 0 0       if ( ( $red_goal_x >= $width ) || ( $red_goal_y >= $height ) )
50             {
51 0           die
52             "The goal position of the red block is out of bounds of the board in file \"$filename\"!\n";
53             }
54              
55 0 0 0       if ( ( $blue_start_x >= $width ) || ( $blue_start_y >= $height ) )
56             {
57 0           die
58             "The starting position of the blue block is out of bounds of the board in file \"$filename\"!\n";
59             }
60              
61 0 0 0       if ( ( $blue_goal_x >= $width ) || ( $blue_goal_y >= $height ) )
62             {
63 0           die
64             "The goal position of the blue block is out of bounds of the board in file \"$filename\"!\n";
65             }
66              
67             my ( $horiz_walls, $vert_walls ) =
68             $input_obj->input_horiz_vert_walls_layout( $width, $height,
69 0           $input_fields->{'layout'} );
70              
71 0           $self->{'width'} = $width;
72 0           $self->{'height'} = $height;
73 0           $self->{'goals'} = [ $red_goal_x, $red_goal_y, $blue_goal_x, $blue_goal_y ];
74              
75 0           $self->{'horiz_walls'} = $horiz_walls;
76 0           $self->{'vert_walls'} = $vert_walls;
77              
78 0           return [ $red_start_x, $red_start_y, $blue_start_x, $blue_start_y ];
79             }
80              
81             sub pack_state
82             {
83 0     0 1   my $self = shift;
84 0           my $state_vector = shift;
85              
86 0           return pack( "cccc", @$state_vector );
87             }
88              
89             sub unpack_state
90             {
91 0     0 1   my $self = shift;
92 0           my $state = shift;
93 0           return [ unpack( "cccc", $state ) ];
94             }
95              
96             sub display_state
97             {
98 0     0 1   my $self = shift;
99 0           my $state = shift;
100             my ( $rx, $ry, $bx, $by ) =
101 0           ( map { $_ + 1 } @{ $self->unpack_state($state) } );
  0            
  0            
102 0           return ("Red=($rx,$ry) ; Blue=($bx,$by)");
103             }
104              
105             sub check_if_unsolvable
106             {
107 0     0 1   my $self = shift;
108 0           my $coords = shift;
109              
110 0   0       return ( ( $coords->[0] == $coords->[2] )
111             && ( $coords->[1] == $coords->[3] ) );
112             }
113              
114             sub check_if_final_state
115             {
116 0     0 1   my $self = shift;
117              
118 0           my $coords = shift;
119              
120 0           return ( join( ",", @$coords ) eq join( ",", @{ $self->{'goals'} } ) );
  0            
121             }
122              
123             sub enumerate_moves
124             {
125 0     0 1   my $self = shift;
126 0           my $coords = shift;
127              
128 0           return (qw(u d l r));
129             }
130              
131             sub perform_move
132             {
133 0     0 1   my $self = shift;
134              
135 0           my $coords = shift;
136 0           my $move = shift;
137              
138 0           my ( $rx, $ry, $bx, $by ) = @$coords;
139              
140 0           my ( $red_new_coords, $red_intermediate_states ) =
141             $self->move_ball_to_end( [ $rx, $ry ], $move );
142              
143 0           my ( $blue_new_coords, $blue_intermediate_states ) =
144             $self->move_ball_to_end( [ $bx, $by ], $move );
145              
146 0           return [ @$red_new_coords, @$blue_new_coords ];
147             }
148              
149             1;
150              
151             __END__