File Coverage

blib/lib/Game/Life/NDim/Board.pm
Criterion Covered Total %
statement 121 147 82.3
branch 23 34 67.6
condition 5 11 45.4
subroutine 19 20 95.0
pod 6 6 100.0
total 174 218 79.8


line stmt bran cond sub pod time code
1             package Game::Life::NDim::Board;
2              
3             # Created on: 2010-01-04 18:52:38
4             # Create by: Ivan Wills
5             # $Id$
6             # $Revision$, $HeadURL$, $Date$
7             # $Revision$, $Source$, $Date$
8              
9 3     3   38481 use Moose;
  3         394460  
  3         32  
10 3     3   17368 use warnings;
  3         7  
  3         99  
11 3     3   14 use feature qw/:5.10/;
  3         4  
  3         281  
12 3     3   572 use version;
  3         1452  
  3         20  
13 3     3   190 use Carp qw/croak cluck confess/;
  3         5  
  3         240  
14 3     3   14 use List::Util qw/max/;
  3         4  
  3         159  
15 3     3   607 use Data::Dumper qw/Dumper/;
  3         5450  
  3         181  
16 3     3   475 use English qw/ -no_match_vars /;
  3         2985  
  3         24  
17 3     3   2507 use Game::Life::NDim::Life;
  3         10  
  3         162  
18 3     3   1637 use Game::Life::NDim::Dim;
  3         12  
  3         117  
19 3     3   2042 use Params::Coerce ();
  3         4311  
  3         104  
20              
21 3     3   26 use overload '""' => \&to_string;
  3         4  
  3         35  
22              
23             our $VERSION = version->new('0.0.3');
24             our @EXPORT_OK = qw//;
25             our %EXPORT_TAGS = ();
26              
27             has items => (
28             is => 'rw',
29             isa => 'ArrayRef',
30             lazy_build => 1,
31             );
32              
33             has dims => (
34             is => 'ro',
35             isa => 'Game::Life::NDim::Dim',
36             required => 1,
37             );
38              
39             has cursor => (
40             is => 'rw',
41             isa => 'Game::Life::NDim::Dim',
42             );
43              
44             has types => (
45             is => 'rw',
46             isa => 'HashRef',
47             default => sub {{ 0 => 0.6, 1 => 0.4 }},
48             );
49              
50             has wrap => (
51             is => 'rw',
52             isa => 'Bool',
53             default => 0,
54             );
55              
56             has verbose => (
57             is => 'rw',
58             isa => 'Bool',
59             default => 0,
60             );
61              
62             around new => sub {
63             my ($new, $class, %params) = @_;
64              
65             if (ref $params{dims} eq 'ARRAY') {
66             $params{dims} = Game::Life::NDim::Dim->new($params{dims});
67             }
68              
69             my $self = $new->($class, %params);
70              
71             $self->reset;
72             $self->seed(%params) if $params{rand};
73             #$self->cursor(Game::Life::NDim::Dim->new([]));
74             for (@{ $self->dims }) {
75             push @{ $self->cursor }, 0;
76             }
77              
78             return $self;
79             };
80              
81             sub _build_items {
82 7     7   15 my ($self, %params) = @_;
83              
84 7 50       21 $self->types = $params{types} if $params{types};
85              
86 7         12 my $items = [];
87 7         11 my $lives = 0;
88              
89 7         10 my $builder;
90             $builder = sub {
91 208     208   340 my ($items, $dims, $pos) = @_;
92 208         379 my $count = $dims->[0];
93              
94 208         613 for my $i ( 0 .. $count - 1 ) {
95 1835 100       2258 if ( @{$dims} == 1 ) {
  1835         4096  
96 1634         6869 $items->[$i] = Game::Life::NDim::Life->new(
97 1634         1781 position => Game::Life::NDim::Dim->new([ @{ $pos }, $i ]),
98             board => $self
99             );
100 1634         2566780 $lives++;
101             }
102             else {
103 201         547 $items->[$i] = [];
104 201         484 my $sub_dims = [ @{ $dims }[ 1 .. @{ $dims } - 1 ] ];
  201         538  
  201         591  
105 201         323 my $sub_pos = [ @{ $pos }, $i ];
  201         431  
106 201         380 my $sub_items = $items->[$i];
107 201         611 $builder->($sub_items, $sub_dims, $sub_pos);
108             }
109             }
110 7         55 };
111 7         216 $builder->($items, $self->dims, []);
112              
113 7         209 return $items;
114             }
115              
116             sub seed {
117 2     2 1 7 my ($self, %params) = @_;
118              
119 2 50       6 $self->types = $params{types} if $params{types};
120              
121 2         4 my $i = 0;
122 2         6 while ( ref (my $life = $self->next_life()) ) {
123 1009         26733 $life->seed($self->types);
124             }
125 2         8 $self->reset;
126              
127 2         5 return $self;
128             }
129              
130             sub reset {
131 12     12 1 991 my ($self) = @_;
132 12         12 my @cursor;
133              
134 12         19 for (@{ $self->dims }) {
  12         373  
135 26         43 push @cursor, 0;
136             }
137              
138 12 50       37 confess "Empty cursor!" if !@cursor;
139              
140 12         20 $cursor[-1] = -1;
141              
142 12         61 $self->cursor(Game::Life::NDim::Dim->new(\@cursor));
143              
144 12         285 return $self;
145             }
146              
147             sub next_life {
148 1021     1021 1 1010 my ($self) = @_;
149 1021         895 my $max_dim;
150              
151 1021 100       26462 return if !$self->cursor->increment($self->dims);
152              
153 1017         25931 my $life = $self->items;
154              
155 1017         1032 my @pos;
156 1017         859 for my $i ( 0 .. @{ $self->dims } - 1 ) {
  1017         24718  
157 3034 50       76690 if ( ! exists $self->cursor->[$i] ) {
158 0         0 die "here?\n";
159 0         0 $self->cursor->[$i] = 0;
160             }
161 3034         75013 my $pos = $self->cursor->[$i];
162 3034         3661 push @pos, $pos;
163 3034 100 66     6175 if ( ref $life eq 'ARRAY' && @{ $life } < $pos + 1 ) {
  3034         8515  
164 301         7749 $life->[$pos] =
165 301 100       248 $i < @{ $self->cursor } - 1 ? []
166             : Game::Life::NDim::Life->new(board => $self, position => $self->cursor);
167             }
168 3034         314006 $life = $life->[$pos];
169             }
170              
171 1017         3219 return $life;
172             }
173              
174             sub set_life {
175 0     0 1 0 my ($self, $life) = @_;
176              
177 0         0 my $curr = $self->items;
178              
179 0         0 for my $i ( @{ $self->cursor } ) {
  0         0  
180 0 0       0 if ( ref $curr->[$i] eq 'ARRAY' ) {
181 0         0 $curr = $curr->[$i];
182             }
183             else {
184 0         0 $curr->[$i] = $life;
185             }
186             }
187              
188 0         0 return $self;
189             }
190              
191             sub get_life {
192 50     50 1 16651 my ($self, $position) = @_;
193              
194 50         1420 my $item = $self->items;
195 50 100       1307 my $min = $self->wrap ? -1 : 0;
196 50 50       96 die if !defined $min;
197              
198 50         41 for my $i (@{ $position } ) {
  50         120  
199 124 100 66     437 croak "Cannot get game position from $position $i >= $min " if $i < $min || !exists $item->[$i];
200 123         189 $item = $item->[$i];
201             }
202              
203 49         399 return $item;
204             }
205              
206             sub to_string {
207 1     1 1 296 my ($self) = @_;
208              
209 1 50       3 die "The dimension of this game is to large to sensibly convert to a string\n" if @{ $self->dims } > 3;
  1         35  
210              
211 1 50       2 my $spacer = ( 10 >= max (@{$self->dims}, scalar @{$self->dims}) ) ? ' ' : '';
  1         27  
  1         24  
212              
213 1         3 my $out = '';
214 1         2 my @outs;
215 1         4 $self->reset;
216 1         2 my $i = 0;
217 1         2 my $level = 0;
218 1         4 while ( ref ( my $life = $self->next_life() ) ) {
219 4 50 33     4 if ( @{$self->cursor} > 2 && $self->cursor->[0] != $level) {
  4         107  
220 0         0 $out .= "\n";
221 0         0 $level = $self->cursor->[0];
222 0         0 push @outs, $out;
223 0         0 $out = '';
224             }
225 4         14 $out .= $life;
226 4 100       97 $out .= $self->cursor->[-1] == $self->dims->[-1] ? "\n" : $spacer;
227 4         12 $i++;
228             }
229 1         5 $self->reset;
230              
231 1 50       4 if (@outs) {
232 0         0 $out .= "\n";
233 0         0 $level = $self->cursor->[0];
234 0         0 push @outs, $out;
235 0         0 $out = '';
236 0         0 my @lines;
237 0         0 for my $level (@outs) {
238 0         0 my $i = 0;
239 0         0 for my $line (split /\n/, $level) {
240 0   0     0 $lines[$i] ||= '';
241 0         0 $lines[$i] .= " $line";
242 0         0 $i++;
243             }
244             }
245 0         0 return join "\n", @lines, '';
246             }
247              
248             #return "Board:\n" . $out . "\nCount = $i\n";
249 1         9 return $out;
250             }
251              
252             1;
253              
254             __END__
255              
256             =head1 NAME
257              
258             Game::Life::NDim::Board - Object representing the board
259              
260             =head1 VERSION
261              
262             This documentation refers to Game::Life::NDim::Board version 0.0.3.
263              
264              
265             =head1 SYNOPSIS
266              
267             use Game::Life::NDim::Board;
268              
269             # Brief but working code example(s) here showing the most common usage(s)
270             # This section will be as far as many users bother reading, so make it as
271             # educational and exemplary as possible.
272              
273              
274             =head1 DESCRIPTION
275              
276             =head1 SUBROUTINES/METHODS
277              
278             =head2 C<seed ( )>
279              
280             =head2 C<reset ( )>
281              
282             =head2 C<next_life ( )>
283              
284             =head2 C<get_life ( )>
285              
286             =head2 C<set_life ( )>
287              
288             =head2 C<to_string ( )>
289              
290             =head2 C<_build_items ( )>
291              
292             =head1 DIAGNOSTICS
293              
294             =head1 CONFIGURATION AND ENVIRONMENT
295              
296             =head1 DEPENDENCIES
297              
298             =head1 INCOMPATIBILITIES
299              
300             =head1 BUGS AND LIMITATIONS
301              
302             There are no known bugs in this module.
303              
304             Please report problems to Ivan Wills (ivan.wills@gmail.com).
305              
306             Patches are welcome.
307              
308             =head1 AUTHOR
309              
310             Ivan Wills - (ivan.wills@gmail.com)
311              
312             =head1 LICENSE AND COPYRIGHT
313              
314             Copyright (c) 2010 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
315             All rights reserved.
316              
317             This module is free software; you can redistribute it and/or modify it under
318             the same terms as Perl itself. See L<perlartistic>. This program is
319             distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
320             without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
321             PARTICULAR PURPOSE.
322              
323             =cut