File Coverage

blib/lib/Games/LMSolve/Alice.pm
Criterion Covered Total %
statement 12 113 10.6
branch 0 28 0.0
condition 0 15 0.0
subroutine 4 14 28.5
pod 8 8 100.0
total 24 178 13.4


line stmt bran cond sub pod time code
1             package Games::LMSolve::Alice;
2             $Games::LMSolve::Alice::VERSION = '0.14.1';
3 1     1   994 use strict;
  1         2  
  1         29  
4 1     1   6 use warnings;
  1         1  
  1         28  
5              
6 1     1   6 use Games::LMSolve::Base qw(%cell_dirs);
  1         2  
  1         89  
7              
8 1     1   6 use vars qw(@ISA);
  1         2  
  1         1340  
9              
10             @ISA = qw(Games::LMSolve::Base);
11              
12             my %cell_flags = (
13             'ADD' => 1,
14             'SUB' => -1,
15             'GOAL' => 0,
16             'START' => 1,
17             'BLANK' => 0,
18             );
19              
20             sub input_board
21             {
22 0     0 1   my $self = shift;
23              
24 0           my $filename = shift;
25              
26 0           my $spec = {
27             'dims' => { 'type' => "xy(integer)", 'required' => 1 },
28             'layout' => { 'type' => "layout", 'required' => 1 },
29             };
30              
31 0           my $input_obj = Games::LMSolve::Input->new();
32 0           my $input_fields = $input_obj->input_board( $filename, $spec );
33              
34             my ( $width, $height ) =
35 0           @{ $input_fields->{'dims'}->{'value'} }{ 'x', 'y' };
  0            
36              
37 0           my (@board);
38              
39             my $line;
40 0           my $line_number = 0;
41 0           my $lines_ref = $input_fields->{'layout'}->{'value'};
42              
43             my $read_line = sub {
44 0 0   0     if ( scalar(@$lines_ref) == $line_number )
45             {
46 0           return 0;
47             }
48 0           $line = $lines_ref->[$line_number];
49 0           $line_number++;
50 0           return 1;
51 0           };
52              
53             my $gen_exception = sub {
54 0     0     my $text = shift;
55             die "$text on $filename at line "
56 0           . ( $input_fields->{'layout'}->{'line_num'} + $line_number + 1 )
57             . "!\n";
58 0           };
59              
60 0           my ( $y, $x );
61 0           my ( $start_x, $start_y );
62              
63 0           $y = 0;
64 0           $x = 0;
65              
66 0           INPUT_LOOP: while ( $read_line->() )
67             {
68 0           while ( length($line) > 0 )
69             {
70 0           $line =~ s/^\s+//;
71 0 0         if ( $line =~ /\S/ )
72             {
73 0 0         if ( $line =~ /^\[([^\]]*)\]/ )
    0          
74             {
75 0           my $flags_string = uc($1);
76 0           my @flags = ( split( /,/, $flags_string ) );
77 0           my @dirs = ( grep { exists( $cell_dirs{$_} ) } @flags );
  0            
78             my @flag_flags =
79 0           ( grep { exists( $cell_flags{$_} ) } @flags );
  0            
80             my @unknown_flags = (
81             grep {
82 0           ( !exists( $cell_dirs{$_} ) )
83 0   0       && ( !exists( $cell_flags{$_} ) )
84             } @flags
85             );
86 0 0         if ( scalar(@unknown_flags) )
87             {
88 0           $gen_exception->( "Unknown Flags on Cell ("
89             . join( ",", @unknown_flags )
90             . ")" );
91             }
92             $board[$y][$x] = {
93 0           'dirs' => { map { $_ => $cell_dirs{$_} } @dirs },
94             'flags' =>
95 0           { map { $_ => $cell_flags{$_} } @flag_flags },
  0            
96             };
97              
98 0 0         if ( exists( $board[$y][$x]->{'flags'}->{'START'} ) )
99             {
100 0 0         if ( defined($start_x) )
101             {
102 0           $gen_exception->("Two starts were defined!\n");
103             }
104 0           $start_x = $x;
105 0           $start_y = $y;
106             }
107 0           $x++;
108 0 0         if ( $x == $width )
109             {
110 0           $x = 0;
111 0           $y++;
112 0 0         if ( $y == $height )
113             {
114 0           last INPUT_LOOP;
115             }
116             }
117 0           $line =~ s/^.*?\]//;
118             }
119             elsif ( $line =~ /^#/ )
120             {
121             # Do nothing - it's a comment
122 0           $line = "";
123             }
124             else
125             {
126 0           $gen_exception->("Junk at Line");
127             }
128             }
129             }
130             }
131              
132 0 0         if ( $y != $height )
133             {
134 0           $gen_exception->(
135             "Input Terminated Prematurely after reading y=$y x=$x");
136             }
137              
138 0 0         if ( !defined($start_x) )
139             {
140 0           $gen_exception->("The Starting Position was not defined anywhere");
141             }
142              
143 0           $self->{'height'} = $height;
144 0           $self->{'width'} = $width;
145 0           $self->{'board'} = \@board;
146              
147 0           return [ $start_x, $start_y, 1 ];
148             }
149              
150             # A function that accepts the expanded state (as an array ref)
151             # and returns an atom that represents it.
152             sub pack_state
153             {
154 0     0 1   my $self = shift;
155 0           my $state_vector = shift;
156 0           return pack( "ccc", @{$state_vector} );
  0            
157             }
158              
159             # A function that accepts an atom that represents a state
160             # and returns an array ref that represents it.
161             sub unpack_state
162             {
163 0     0 1   my $self = shift;
164 0           my $state = shift;
165 0           return [ unpack( "ccc", $state ) ];
166             }
167              
168             # Accept an atom that represents a state and output a
169             # user-readable string that describes it.
170             sub display_state
171             {
172 0     0 1   my $self = shift;
173 0           my $state = shift;
174 0           my ( $x, $y, $d ) = @{ $self->unpack_state($state) };
  0            
175 0           return sprintf( "X = %i ; Y = %i ; d = %i", $x + 1, $y + 1, $d );
176             }
177              
178             # This function checks if a state it receives as an argument is a
179             # dead-end one.
180             sub check_if_unsolvable
181             {
182 0     0 1   my $self = shift;
183 0           my $coords = shift;
184 0           return ( $coords->[2] == 0 );
185             }
186              
187             sub check_if_final_state
188             {
189 0     0 1   my $self = shift;
190              
191 0           my $coords = shift;
192             return
193             exists(
194 0           $self->{'board'}->[ $coords->[1] ][ $coords->[0] ]->{'flags'}->{'GOAL'}
195             );
196             }
197              
198             # This function enumerates the moves accessible to the state.
199             # If it returns a move, it still does not mean that it is a valid
200             # one. I.e: it is possible that it is illegal to perform it.
201             sub enumerate_moves
202             {
203 0     0 1   my $self = shift;
204              
205 0           my $coords = shift;
206             return
207             keys(
208 0           %{ $self->{'board'}->[ $coords->[1] ][ $coords->[0] ]->{'dirs'} } );
  0            
209             }
210              
211             # This function accepts a state and a move. It tries to perform the
212             # move on the state. If it is succesful, it returns the new state.
213             #
214             # Else, it returns undef to indicate that the move is not possible.
215             sub perform_move
216             {
217 0     0 1   my $self = shift;
218              
219 0           my $coords = shift;
220 0           my $m = shift;
221              
222 0           my $offsets = [ map { $_ * $coords->[2] } @{ $cell_dirs{$m} } ];
  0            
  0            
223 0           my @new_coords = @$coords;
224 0           $new_coords[0] += $offsets->[0];
225 0           $new_coords[1] += $offsets->[1];
226              
227             my $new_cell =
228 0           $self->{'board'}->[ $new_coords[1] ][ $new_coords[0] ]->{'flags'};
229              
230             # Check if we are out of the bounds of the board.
231 0 0 0       if ( ( $new_coords[0] < 0 )
      0        
      0        
      0        
232             || ( $new_coords[0] >= $self->{'width'} )
233             || ( $new_coords[1] < 0 )
234             || ( $new_coords[1] >= $self->{'height'} )
235             || exists( $new_cell->{'BLANK'} ) )
236             {
237 0           return;
238             }
239              
240 0 0         if ( exists( $new_cell->{'ADD'} ) )
    0          
241             {
242 0           $new_coords[2]++;
243             }
244             elsif ( exists( $new_cell->{'SUB'} ) )
245             {
246 0           $new_coords[2]--;
247             }
248              
249 0           return [@new_coords];
250             }
251              
252             1;
253              
254             __END__