|
|
1 | package GCE::StackRef; |
|
|
2 | use strict; |
|
|
3 | =head1 NAME |
|
|
4 | |
|
|
5 | GCE::StackRef - a intelligent reference to a mapspace or inventory (arch stack) |
|
|
6 | |
|
|
7 | =head1 SYNOPSIS |
|
|
8 | |
|
|
9 | GCE::StackRef->new (...); |
|
|
10 | |
|
|
11 | =over 4 |
|
|
12 | |
|
|
13 | =cut |
|
|
14 | |
|
|
15 | use Scalar::Util qw/weaken/; |
|
|
16 | use Storable qw/dclone/; |
|
|
17 | use Deliantra; |
|
|
18 | use Carp; |
|
|
19 | use GCE::Util; |
|
|
20 | use base qw/Object::Event/; |
|
|
21 | |
|
|
22 | sub new { |
|
|
23 | my $class = shift; |
|
|
24 | my $self = { cursors => [], @_ }; |
|
|
25 | |
|
|
26 | $self->{src} ||= []; |
|
|
27 | |
|
|
28 | if (@{$self->{src}} == 3) { |
|
|
29 | return GCE::StackRef::Map->_new ($self); |
|
|
30 | } elsif (@{$self->{src}} == 2) { |
|
|
31 | return GCE::StackRef::Arch->_new ($self); |
|
|
32 | } else { |
|
|
33 | return GCE::StackRef::Dummy->_new ($self); |
|
|
34 | } |
|
|
35 | |
|
|
36 | bless $self, $class; |
|
|
37 | |
|
|
38 | return $self; |
|
|
39 | } |
|
|
40 | |
|
|
41 | sub _new { |
|
|
42 | my $class = shift; |
|
|
43 | my $self = shift; |
|
|
44 | bless $self, $class; |
|
|
45 | |
|
|
46 | $self->init_object_events; |
|
|
47 | |
|
|
48 | $self->init; |
|
|
49 | $self |
|
|
50 | } |
|
|
51 | |
|
|
52 | sub cursor { |
|
|
53 | my ($self, $z) = @_; |
|
|
54 | my $c = |
|
|
55 | ($self->{cursors}->[$z] |
|
|
56 | ||= GCE::StackRef->new (src => [$self, $z])); |
|
|
57 | weaken $self->{cursors}->[$z]; |
|
|
58 | $c |
|
|
59 | } |
|
|
60 | |
|
|
61 | sub cursor_change { |
|
|
62 | my ($self, $z, $msg, $inval) = @_; |
|
|
63 | $self->{cursors}->[$z]->changed ($msg, $inval) |
|
|
64 | if defined $self->{cursors}->[$z]; |
|
|
65 | |
|
|
66 | $self->{cursors}->[$z] = undef if $inval; |
|
|
67 | } |
|
|
68 | |
|
|
69 | sub changed : event_cb { |
|
|
70 | my ($self, $msg, $invalidated) = @_; |
|
|
71 | |
|
|
72 | warn "$self (@{$self->{src}}) owner $self->{owner}" |
|
|
73 | . " changed: $msg, invalid? ($invalidated)\n"; |
|
|
74 | if ($invalidated) { |
|
|
75 | $_->changed ($msg, $invalidated) |
|
|
76 | for grep { defined $_ } @{$self->{cursors}}; |
|
|
77 | |
|
|
78 | delete $self->{src}; |
|
|
79 | delete $self->{ref}; |
|
|
80 | delete $self->{map}; |
|
|
81 | } |
|
|
82 | } |
|
|
83 | |
|
|
84 | sub overlay { |
|
|
85 | my ($self) = @_; |
|
|
86 | } |
|
|
87 | |
|
|
88 | package GCE::StackRef::Dummy; |
|
|
89 | use Storable qw/dclone/; |
|
|
90 | |
|
|
91 | use base qw/GCE::StackRef/; |
|
|
92 | |
|
|
93 | sub init { |
|
|
94 | my ($self) = @_; |
|
|
95 | } |
|
|
96 | |
|
|
97 | sub push { |
|
|
98 | my ($self, $arch) = @_; |
|
|
99 | $self->commit ('push_dummy'); |
|
|
100 | } |
|
|
101 | |
|
|
102 | sub swap { |
|
|
103 | my ($self, $swapidx, $ownidx) = @_; |
|
|
104 | $self->commit ('swap_dummy'); |
|
|
105 | } |
|
|
106 | |
|
|
107 | sub replace { |
|
|
108 | my ($self, $idx, $new) = @_; |
|
|
109 | $self->cursor_change ($idx, 'replace_dummy'); |
|
|
110 | $self->commit ('replace_dummy'); |
|
|
111 | } |
|
|
112 | |
|
|
113 | sub remove { |
|
|
114 | my ($self, $idx) = @_; |
|
|
115 | $self->cursor_change ($idx, 'remove_dummy'); |
|
|
116 | $self->commit ('remove_dummy'); |
|
|
117 | } |
|
|
118 | |
|
|
119 | sub commit { |
|
|
120 | my ($self, $change) = @_; |
|
|
121 | $self->changed ($self->{owner} . '#' . $change); |
|
|
122 | } |
|
|
123 | |
|
|
124 | sub size { |
|
|
125 | 0 |
|
|
126 | } |
|
|
127 | |
|
|
128 | sub get { |
|
|
129 | my $self = shift; |
|
|
130 | my $z = shift; |
|
|
131 | |
|
|
132 | return () unless defined $z; |
|
|
133 | |
|
|
134 | $self->{template} |
|
|
135 | ? dclone ($self->{template}) |
|
|
136 | : { _name => 'empty_archetype' } |
|
|
137 | } |
|
|
138 | |
|
|
139 | package GCE::StackRef::Map; |
|
|
140 | use GCE::Util; |
|
|
141 | use Deliantra; |
|
|
142 | use Deliantra::MapWidget; |
|
|
143 | |
|
|
144 | use base qw/GCE::StackRef/; |
|
|
145 | |
|
|
146 | sub init { |
|
|
147 | my ($self) = @_; |
|
|
148 | $self->{map} = $self->{src}->[0]; |
|
|
149 | $self->{x} = $self->{src}->[1]; |
|
|
150 | $self->{y} = $self->{src}->[2]; |
|
|
151 | $self->{ms} = $self->{map}->{map}->get ($self->{x}, $self->{y}); |
|
|
152 | } |
|
|
153 | |
|
|
154 | sub overlay { |
|
|
155 | my ($self) = @_; |
|
|
156 | # XXX: Fixme! there is still a bug in removing overlays!! |
|
|
157 | $self->update_cursor_overlay ('stack_view'); |
|
|
158 | } |
|
|
159 | |
|
|
160 | sub push { |
|
|
161 | my ($self, $arch) = @_; |
|
|
162 | |
|
|
163 | push @{$self->{ms}}, dclone ($arch->getarch); |
|
|
164 | |
|
|
165 | $self->commit ('push_ms'); |
|
|
166 | } |
|
|
167 | |
|
|
168 | sub swap { |
|
|
169 | my ($self, $swapidx, $ownidx) = @_; |
|
|
170 | |
|
|
171 | my $ms = $self->{ms}; |
|
|
172 | |
|
|
173 | ($ms->[$swapidx], $ms->[$ownidx]) |
|
|
174 | = ($ms->[$ownidx], $ms->[$swapidx]); |
|
|
175 | |
|
|
176 | $self->cursor_change ($swapidx, 'swap_ms'); |
|
|
177 | $self->cursor_change ($ownidx, 'swap_ms'); |
|
|
178 | |
|
|
179 | $self->commit ('swap_ms'); |
|
|
180 | } |
|
|
181 | |
|
|
182 | sub replace { |
|
|
183 | my ($self, $idx, $new) = @_; |
|
|
184 | |
|
|
185 | splice @{$self->{'ms'}}, $idx, 1, $new; |
|
|
186 | $self->cursor_change ($idx, 'replace_ms'); |
|
|
187 | |
|
|
188 | $self->commit ('replace_ms'); |
|
|
189 | } |
|
|
190 | |
|
|
191 | sub remove { |
|
|
192 | my ($self, $idx) = @_; |
|
|
193 | |
|
|
194 | splice @{$self->{ms}}, $idx, 1; |
|
|
195 | $self->cursor_change ($idx, 'remove_ms'); |
|
|
196 | |
|
|
197 | $self->commit ('remove_ms'); |
|
|
198 | } |
|
|
199 | |
|
|
200 | sub commit { |
|
|
201 | my ($self, $change) = @_; |
|
|
202 | |
|
|
203 | $change = 'unknown_edit' unless defined $change; |
|
|
204 | $change = $self->{owner} . '#' . $change; |
|
|
205 | |
|
|
206 | my $map = $self->{map}; |
|
|
207 | $map = $map->{map}; |
|
|
208 | |
|
|
209 | $map->change_begin ($change . ' on ' . $self); |
|
|
210 | |
|
|
211 | $map->change_stack ($self->{x}, $self->{y}, $self->{ms}); |
|
|
212 | |
|
|
213 | if (my $changeset = $map->change_end) { |
|
|
214 | my $undo_stack = ($map->{undo_stack} ||= []); |
|
|
215 | |
|
|
216 | my $str_self = "$self"; |
|
|
217 | |
|
|
218 | if ($map->{undo_stack_pos} > 0 |
|
|
219 | && $undo_stack->[$map->{undo_stack_pos} - 1]->{title} |
|
|
220 | =~ /^attribute_edit:.*? on \Q$str_self\E$/) { |
|
|
221 | $map->{undo_stack_pos}--; |
|
|
222 | |
|
|
223 | warn "merged change ($changeset->{title})\n"; |
|
|
224 | } else { |
|
|
225 | warn "added change ($changeset->{title})\n"; |
|
|
226 | } |
|
|
227 | |
|
|
228 | splice @{ $map->{undo_stack} ||= [] }, |
|
|
229 | $map->{undo_stack_pos}++, 1e6, |
|
|
230 | $changeset; |
|
|
231 | } |
|
|
232 | $self->{ms} = $self->{map}->{map}->get ($self->{x}, $self->{y}); |
|
|
233 | |
|
|
234 | $::MAINWIN->broadcast_cursor_changes ($self->{map}, $self->{x}, $self->{y}); |
|
|
235 | |
|
|
236 | $self->changed ($change); |
|
|
237 | } |
|
|
238 | |
|
|
239 | sub size { |
|
|
240 | @{$_[0]->{ms} || []} |
|
|
241 | } |
|
|
242 | |
|
|
243 | sub get { |
|
|
244 | my ($self, $z) = @_; |
|
|
245 | |
|
|
246 | if (defined $z) { |
|
|
247 | return undef unless @{$self->{ms}}; |
|
|
248 | return $self->{ms}->[$z] |
|
|
249 | } else { |
|
|
250 | return @{$self->{ms} || []} |
|
|
251 | } |
|
|
252 | } |
|
|
253 | |
|
|
254 | sub update_cursor_overlay { |
|
|
255 | my ($self, $owner) = @_; |
|
|
256 | |
|
|
257 | $self->{map}->{map}->{overlay_holder}->{$owner} = "$self"; |
|
|
258 | |
|
|
259 | $self->{map}->{map}->overlay ('srovl_' . $owner => |
|
|
260 | $self->{x} * TILESIZE, |
|
|
261 | $self->{y} * TILESIZE, |
|
|
262 | TILESIZE, |
|
|
263 | TILESIZE, |
|
|
264 | sub { |
|
|
265 | my ($self, $x, $y) = @_; |
|
|
266 | |
|
|
267 | if (!$self->{_conn_upd_curs_gc_fg}->{$owner}) { |
|
|
268 | my $gc |
|
|
269 | = $self->{_conn_upd_curs_gc_fg}->{$owner} |
|
|
270 | = Gtk2::Gdk::GC->new ($self->{window}); |
|
|
271 | my $cm = $self->{window}->get_colormap; |
|
|
272 | $gc->set_foreground ( |
|
|
273 | gtk2_get_color ( |
|
|
274 | $self, $owner eq 'stack_view' ? "green" : "blue")); |
|
|
275 | $gc->set_background (gtk2_get_color ($self, "black")); |
|
|
276 | } |
|
|
277 | |
|
|
278 | $self->{window}->draw_rectangle ( |
|
|
279 | $self->{_conn_upd_curs_gc_fg}->{$owner}, |
|
|
280 | 0, |
|
|
281 | $x + ($owner eq 'stack_view' ? 1 : 0), |
|
|
282 | $y + ($owner eq 'stack_view' ? 1 : 0), |
|
|
283 | TILESIZE - ($owner eq 'stack_view' ? 3 : 1), |
|
|
284 | TILESIZE - ($owner eq 'stack_view' ? 3 : 1), |
|
|
285 | ); |
|
|
286 | } |
|
|
287 | ); |
|
|
288 | } |
|
|
289 | |
|
|
290 | sub DESTROY { |
|
|
291 | my ($self) = @_; |
|
|
292 | if ($self->{map}->{map}->{overlay_holder}->{'stack_view'} eq "$self") { |
|
|
293 | $self->{map}->{map}->overlay ('srovl_stack_view') |
|
|
294 | } |
|
|
295 | warn "$self StackRef::Map DESTROYED!\n"; |
|
|
296 | } |
|
|
297 | |
|
|
298 | package GCE::StackRef::Arch; |
|
|
299 | |
|
|
300 | use Carp; |
|
|
301 | use GCE::Util; |
|
|
302 | use base qw/GCE::StackRef/; |
|
|
303 | |
|
|
304 | sub init { |
|
|
305 | my ($self) = @_; |
|
|
306 | $self->{ref} = $self->{src}->[0]; |
|
|
307 | $self->{z} = $self->{src}->[1]; |
|
|
308 | } |
|
|
309 | |
|
|
310 | sub get { |
|
|
311 | my ($self, $z) = @_; |
|
|
312 | my $a = $self->{ref}->get ($self->{z}); |
|
|
313 | $a = $a->{inventory}->[$z] if defined $z; |
|
|
314 | unless (defined $a) { |
|
|
315 | Carp::confess "GOT UNDEF ARCH IN ARCHREF $self->{ref}, $self->{z}, $z!"; |
|
|
316 | } |
|
|
317 | $a |
|
|
318 | } |
|
|
319 | |
|
|
320 | sub push { |
|
|
321 | my ($self, $arch) = @_; |
|
|
322 | |
|
|
323 | my $a = $self->get; |
|
|
324 | push @{$a->{inventory}}, $arch; |
|
|
325 | $self->commit ('push_inv'); |
|
|
326 | } |
|
|
327 | |
|
|
328 | sub swap { |
|
|
329 | my ($self, $swapidx, $ownidx) = @_; |
|
|
330 | |
|
|
331 | my $a = $self->get; |
|
|
332 | my $inv = $a->{inventory}; |
|
|
333 | ($inv->[$swapidx], $inv->[$ownidx]) |
|
|
334 | = ($inv->[$ownidx], $inv->[$swapidx]); |
|
|
335 | $self->commit ('swap_inv'); |
|
|
336 | } |
|
|
337 | |
|
|
338 | sub replace { |
|
|
339 | my ($self, $idx, $new) = @_; |
|
|
340 | |
|
|
341 | my $a = $self->get; |
|
|
342 | splice @{$a->{inventory}}, $idx, 1, $new; |
|
|
343 | $self->cursor_change ($idx, 'replace_inv'); |
|
|
344 | $self->commit ('replace_inv'); |
|
|
345 | } |
|
|
346 | |
|
|
347 | sub remove { |
|
|
348 | my ($self, $idx) = @_; |
|
|
349 | |
|
|
350 | my $a = $self->get; |
|
|
351 | splice @{$a->{inventory}}, $idx, 1; |
|
|
352 | $self->cursor_change ($idx, 'remove_inv', 1); |
|
|
353 | |
|
|
354 | $self->commit ('remove_inv'); |
|
|
355 | } |
|
|
356 | |
|
|
357 | sub commit { |
|
|
358 | my ($self, $msg) = @_; |
|
|
359 | $self->{ref}->commit ($msg); |
|
|
360 | $self->changed ($self->{owner} . '#' . $msg); |
|
|
361 | } |
|
|
362 | |
|
|
363 | sub type { |
|
|
364 | my ($self) = @_; |
|
|
365 | Deliantra::arch_attr $self->get; |
|
|
366 | } |
|
|
367 | |
|
|
368 | sub attr { |
|
|
369 | my ($self, $key) = @_; |
|
|
370 | $self->get->{$key} |
|
|
371 | } |
|
|
372 | |
|
|
373 | sub attr_or_arch { |
|
|
374 | my ($self, $key) = @_; |
|
|
375 | def ($self->attr ($key), $self->archetype->{$key}) |
|
|
376 | } |
|
|
377 | |
|
|
378 | sub archetype { |
|
|
379 | my ($self) = @_; |
|
|
380 | |
|
|
381 | $Deliantra::ARCH{$self->get->{_name}} || $Deliantra::ARCH{empty_archetype}; |
|
|
382 | } |
|
|
383 | |
|
|
384 | sub picker_folder { |
|
|
385 | my ($self) = @_; |
|
|
386 | my $folder = $self->archetype->{editor_folder}; |
|
|
387 | my @a = split /\//, $folder; |
|
|
388 | $a[0] |
|
|
389 | } |
|
|
390 | |
|
|
391 | sub longname { |
|
|
392 | my ($self) = @_; |
|
|
393 | |
|
|
394 | my $name = $self->attr ('_name'); |
|
|
395 | my $rname = $self->attr ('name'); |
|
|
396 | my $t = $self->type; |
|
|
397 | |
|
|
398 | $name . ($rname ? " - $rname" : "") . " ($t->{name})" |
|
|
399 | } |
|
|
400 | |
|
|
401 | sub field_value_is_default { |
|
|
402 | my ($self, $key, $val) = @_; |
|
|
403 | my $al_arch = $self->archetype; |
|
|
404 | |
|
|
405 | # XXX: Was '... and $val', does this fix problems? |
|
|
406 | (defined ($al_arch->{$key}) && $al_arch->{$key} ne $val) |
|
|
407 | || (not (defined $al_arch->{$key}) and $val) |
|
|
408 | } |
|
|
409 | |
|
|
410 | sub reset_to_defaults { |
|
|
411 | my ($self) = @_; |
|
|
412 | |
|
|
413 | my $arch = $self->get; |
|
|
414 | |
|
|
415 | for (keys %$arch) { |
|
|
416 | delete $arch->{$_} if $_ ne '_name' |
|
|
417 | } |
|
|
418 | |
|
|
419 | $self->commit ('reset_to_defaults'); |
|
|
420 | } |
|
|
421 | |
|
|
422 | sub attr_set { |
|
|
423 | my ($self, $key, $value, $type, $src) = @_; |
|
|
424 | |
|
|
425 | my $arch = $self->get; |
|
|
426 | my $al_arch = $self->archetype; |
|
|
427 | |
|
|
428 | if (ref $value) { |
|
|
429 | $arch->{$key} = $value; |
|
|
430 | |
|
|
431 | } else { |
|
|
432 | if (not defined $al_arch->{$key}) { |
|
|
433 | if ((not defined $value) || $value eq '' |
|
|
434 | || ($type eq 'bool' && $value eq '0')) { |
|
|
435 | # try to normalize |
|
|
436 | delete $arch->{$key}; |
|
|
437 | } else { |
|
|
438 | # try to normalize |
|
|
439 | $arch->{$key} = $value; |
|
|
440 | } |
|
|
441 | } else { |
|
|
442 | if ($al_arch->{$key} ne $value) { |
|
|
443 | $arch->{$key} = $value; |
|
|
444 | } else { |
|
|
445 | # try to normalize |
|
|
446 | delete $arch->{$key}; |
|
|
447 | } |
|
|
448 | } |
|
|
449 | } |
|
|
450 | |
|
|
451 | $self->commit ($src . '!attribute_edit:' . $key); |
|
|
452 | } |
|
|
453 | |
|
|
454 | =head1 AUTHOR |
|
|
455 | |
|
|
456 | Marc Lehmann <schmorp@schmorp.de> |
|
|
457 | http://home.schmorp.de/ |
|
|
458 | |
|
|
459 | Robin Redeker <elmex@ta-sa.org> |
|
|
460 | http://www.ta-sa.org/ |
|
|
461 | |
|
|
462 | =cut |
|
|
463 | 1; |
