File Coverage

File:	blib/lib/Language/Homespring.pm
Coverage:	88.0%

line	stmt	bran	cond	sub	time	code
1						package Language::Homespring;
2
3						$VERSION = 0.04;
4
5	4 4 4			4	17 8 30	use strict;
6	4 4 4			4	23 18 26	use warnings;
7
8	4 4 4			4	31 10 44	use Language::Homespring::Node;
9	4 4 4			4	39 8 37	use Language::Homespring::Salmon;
10	4 4 4			4	37 10 38	use Language::Homespring::Snowmelt;
11	4 4 4			4	32 10 35	use Language::Homespring::River;
12
13						sub new {
14	26			26	70	my $class = shift;
15	26				98	my $self = bless {}, $class;
16
17	26				62	my $options = shift;
18	26				82	$self->{root_node} = undef;
19	26				77	$self->{salmon} = [];
20	26				81	$self->{snowmelt} = [];
21	26				74	$self->{new_salmon} = [];
22	26				79	$self->{dead_salmon} = [];
23	26				73	$self->{output} = '';
24	26				69	$self->{universe_ok} = 1;
25
26	26				70	return $self;
27						}
28
29						sub parse {
30	26			26	77	my ($self, $source) = @_;
31
32	151				322	my @tokens =
33	151 151				363 272	map{s/(\.$)\|(^\.)/\n/g; $_}
34	151 151				340 263	map{s/\. / /g; $_}
35	26 151				223 336	map{s/ \././g; $_}
36						split /(?:(?<!\.) (?!\.))\|(?:\n(?!\.))/, $source;
37
38						#print((join '\|', @tokens)."\n\n");
39
40	26				201	$self->{root_node} = new Language::Homespring::Node({
41						'interp' => $self,
42						'node_name' => shift @tokens,
43						});
44	26				86	my $parent = $self->{root_node};
45
46	26				67	for my $token(@tokens){
47	125	100			304	if ($token){
48	95				504	my $new_node = new Language::Homespring::Node({
49						'interp' => $self,
50						'node_name' => $token,
51						'parent_node' => $parent,
52						});
53	95				363	$parent->add_child($new_node);
54
55	95				522	my $new_river = new Language::Homespring::River({
56						'interp' => $self,
57						'up_node' => $new_node,
58						'down_node' => $parent,
59						});
60	95				339	$parent->add_river_up($new_river);
61	95				302	$new_node->add_river_down($new_river);
62
63	95				309	$parent = $new_node;
64						}else{
65	30	50			114	if (defined $parent->{parent_node}){
66	30				108	$parent = $parent->{parent_node};
67						}
68						}
69						}
70						}
71
72						sub tick {
73	155			155	383	my ($self) = @_;
74	155				239	my @nodes;
75
76	155				384	$self->{output} = '';
77
78						# has our universe been smashed?
79	155	100			536	return if !$self->{universe_ok};
80
81						# process snowmelts
82	151				447	@nodes = $self->_get_nodes('snowmelt');
83	151				421	for (@nodes){
84						#spawn a new snowmelt
85	31				165	my $snowmelt = new Language::Homespring::Snowmelt({'interp' => $self, 'location' => $_});
86	31 31				68 136	push @{$self->{snowmelt}}, $snowmelt;
87						}
88	151 151 151				192 250 611	$_->move() for (@{$self->{snowmelt}});
89
90						# has our universe been smashed?
91	151	100			523	return if !$self->{universe_ok};
92
93
94						# process water
95
96						# turn everything off
97	149				444	$self->_set_all('water', 0);
98
99						# water from springs
100	149				437	@nodes = $self->_get_all_nodes();
101	149				431	for (@nodes){
102	700	100			2975	$self->_water_downwards($_) if $_->{spring};
103						}
104
105						# process electricity
106
107						# turn everything off
108	149				576	$self->_set_recurse($self->{root_node}, 'power', 0);
109
110						# process "powers"
111	149				454	@nodes = $self->_get_nodes('powers');
112	149				395	for(@nodes){
113	116	100			443	if (!$_->{destroyed}){
114	110				308	$self->_power_downwards($_);
115						}
116						}
117
118						# process "hydro power"
119	149				452	@nodes = $self->_get_nodes('hydro power');
120	149				403	for (@nodes){
121	19	100	100		165	$self->_power_downwards($_) if $_->{water} && !$_->{destroyed};
122						}
123
124						# process "power invert"
125	149				426	@nodes = $self->_get_nodes('power invert');
126	149				418	for (@nodes){
127	18	100	100		151	$self->_power_downwards($_) if !$_->{power} && !$_->{destroyed};
128						}
129
130						# process salmon
131
132	149 149 149				191 248 709	$_->move() for (@{$self->{salmon}});
133
134						# sort out dead salmon
135	149 338				444 599	@{$self->{salmon}} = grep{
136	149				477	my $ok = 1;
137	338 338				540 1131	for my $dead(@{$self->{dead_salmon}}){
138	781	100			2822	$ok = 0 if $_ == $dead;
139						}
140	338				781	$ok;
141	149				293	}@{$self->{salmon}};
142
143						# sort out new salmon
144	149 149 149				284 390 410	push @{$self->{salmon}}, @{$self->{new_salmon}};
145	149				445	$self->{new_salmon} = [];
146
147						# process others
148
149	149				477	@nodes = $self->_get_nodes('hatchery');
150	149				385	for (@nodes){
151	149	100			578	if ($_->{power}){
152	103 103				193 342	my $location = @{$_->{rivers_up}}[0];
153	103				642	my $salmon = new Language::Homespring::Salmon({'interp' => $self,'mature' => 1, 'upstream' => 1, 'location' => $location});
154	103 103				227 482	push @{$self->{salmon}}, $salmon;
155						}
156						}
157
158						# @nodes = $self->_get_nodes('bear');
159						# for (@nodes){
160						# for my $salmon($_->get_salmon()){
161						# $salmon->kill() if $salmon->{mature};
162						# }
163						# }
164
165	149				533	return $self->{output};
166						}
167
168						sub run{
169	0			0	0	my ($self, $max_ticks, $delimit) = @_;
170	0				0	my $tick = 0;
171	0				0	while(1){
172	0				0	print $self->tick();
173	0	0			0	print $delimit if defined($delimit);
174	0				0	$tick++;
175	0	0	0		0	return if (defined($max_ticks) && ($tick >= $max_ticks));
176	0	0			0	return if !$self->{universe_ok};
177						}
178						}
179
180						sub _set_all {
181	149			149	434	my ($self, $prop, $value) = @_;
182	149				546	$self->_set_recurse($self->{root_node}, $prop, $value);
183						}
184
185						sub _set_recurse {
186	1400			1400	4149	my ($self, $node, $prop, $value) = @_;
187	1400				3287	$node->{$prop} = $value;
188	1400 1400 1400				1685 2267 8314	$self->_set_recurse($_, $prop, $value) for @{$node->{child_nodes}};
189						}
190
191						sub _get_nodes {
192	747			747	1990	my ($self, $name) = @_;
193	747				2768	return $self->_get_nodes_i($self->{root_node}, $name);
194						}
195
196						sub _get_nodes_i {
197	3512			3512	9708	my ($self, $node, $name) = @_;
198	3512				6770	my @out = ();
199	3512	100			12581	push @out, $node if ($node->{node_name} eq $name);
200	3512 3512 3512				4271 5576 16182	push @out, $self->_get_nodes_i($_, $name) for @{$node->{child_nodes}};
201	3512				12635	return @out;
202						}
203
204						sub _get_all_nodes {
205	149			149	370	my ($self) = @_;
206	149				519	return $self->_get_all_nodes_i($self->{root_node});
207						}
208
209						sub _get_all_nodes_i {
210	700			700	1793	my ($self, $node) = @_;
211	700				1344	my @out = ();
212	700				1383	push @out, $node;
213	700 700 700				851 1120 3147	push @out, $self->_get_all_nodes_i($_) for @{$node->{child_nodes}};
214	700				2772	return @out;
215						}
216
217						sub _power_downwards {
218	337			337	883	my ($self, $node) = @_;
219
220	337	100			1360	return if (!$node->{parent_node});
221
222	234				690	$node->{parent_node}->{power} = 1;
223
224	234	100			948	return if ($node->{parent_node}->{node_name} eq 'power invert');
225	229	100			925	return if ($node->{parent_node}->{node_name} eq 'insulated');
226	224	100			922	return if ($node->{parent_node}->{node_name} eq 'force field');
227	211	50	33		1055	return if (($node->{parent_node}->{node_name} eq 'bridge') && ($node->{parent_node}->{destroyed}));
228
229						# TODO: "sense" and "switch"
230
231	211				704	$self->_power_downwards($node->{parent_node});
232						}
233
234						sub _water_downwards {
235	506			506	1285	my ($self, $node) = @_;
236
237	506	100			1960	return if (!$node->{parent_node});
238
239	340				1005	$node->{parent_node}->{water} = 1;
240
241	340	100	100		1778	return if (($node->{parent_node}->{node_name} eq 'force field') && ($node->{parent_node}->{power}));
242	334	50	33		1671	return if (($node->{parent_node}->{node_name} eq 'bridge') && ($node->{parent_node}->{destroyed}));
243	334	50	33		1668	return if (($node->{parent_node}->{node_name} eq 'evaporates') && ($node->{parent_node}->{power}));
244
245	334				1095	$self->_water_downwards($node->{parent_node});
246						}
247