ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra/Deliantra.pm
(Generate patch)

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.77 by root, Tue Nov 7 22:40:26 2006 UTC vs.
Revision 1.101 by root, Tue Apr 10 09:37:03 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.95'; 9our $VERSION = '0.98';
10 10
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
… …
19 19
20our @EXPORT = qw( 20our @EXPORT = qw(
21 read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents 21 read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents
22); 22);
23 23
24use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working 24use JSON::XS qw(from_json to_json);
25
26sub from_json($) {
27 $JSON::Syck::ImplicitUnicode = 1;
28 JSON::Syck::Load $_[0]
29}
30
31sub to_json($) {
32 $JSON::Syck::ImplicitUnicode = 0;
33 JSON::Syck::Dump $_[0]
34}
35 25
36our $LIB = $ENV{CROSSFIRE_LIBDIR}; 26our $LIB = $ENV{CROSSFIRE_LIBDIR};
37 27
38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" 28our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire" 29 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
… …
58 qw(move_type move_block move_allow move_on move_off move_slow); 48 qw(move_type move_block move_allow move_on move_off move_slow);
59 49
60# same as in server save routine, to (hopefully) be compatible 50# same as in server save routine, to (hopefully) be compatible
61# to the other editors. 51# to the other editors.
62our @FIELD_ORDER_MAP = (qw( 52our @FIELD_ORDER_MAP = (qw(
53 file_format_version
63 name attach swap_time reset_timeout fixed_resettime difficulty region 54 name attach swap_time reset_timeout fixed_resettime difficulty region
64 shopitems shopgreed shopmin shopmax shoprace 55 shopitems shopgreed shopmin shopmax shoprace
65 darkness width height enter_x enter_y msg maplore 56 darkness width height enter_x enter_y msg maplore
66 unique template 57 unique template
67 outdoor temp pressure humid windspeed winddir sky nosmooth 58 outdoor temp pressure humid windspeed winddir sky nosmooth
… …
70 61
71our @FIELD_ORDER = (qw( 62our @FIELD_ORDER = (qw(
72 elevation 63 elevation
73 64
74 name name_pl custom_name attach title race 65 name name_pl custom_name attach title race
75 slaying skill msg lore other_arch face 66 slaying skill msg lore other_arch
76 #todo-events 67 is_animated animation face
77 animation is_animated 68 magicmap smoothlevel smoothface
78 str dex con wis pow cha int 69 str dex con wis pow cha int
79 hp maxhp sp maxsp grace maxgrace 70 hp maxhp sp maxsp grace maxgrace
80 exp perm_exp expmul 71 exp perm_exp expmul
81 food dam luck wc ac x y speed speed_left move_state attack_movement 72 food dam luck wc ac x y speed speed_left move_state attack_movement
82 nrof level direction type subtype attacktype 73 nrof level direction type subtype attacktype
… …
138sub MOVE_FLY_HIGH (){ 0x04 } 129sub MOVE_FLY_HIGH (){ 0x04 }
139sub MOVE_FLYING (){ 0x06 } 130sub MOVE_FLYING (){ 0x06 }
140sub MOVE_SWIM (){ 0x08 } 131sub MOVE_SWIM (){ 0x08 }
141sub MOVE_BOAT (){ 0x10 } 132sub MOVE_BOAT (){ 0x10 }
142sub MOVE_KNOWN (){ 0x1f } # all of above 133sub MOVE_KNOWN (){ 0x1f } # all of above
143sub MOVE_ALLBIT (){ 0x10000 }
144sub MOVE_ALL (){ 0x1001f } # very special value, more PITA 134sub MOVE_ALL (){ 0x10000 } # very special value
135
136our %MOVE_TYPE = (
137 walk => MOVE_WALK,
138 fly_low => MOVE_FLY_LOW,
139 fly_high => MOVE_FLY_HIGH,
140 flying => MOVE_FLYING,
141 swim => MOVE_SWIM,
142 boat => MOVE_BOAT,
143 all => MOVE_ALL,
144);
145
146our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat);
147
148{
149 package Crossfire::MoveType;
150
151 use overload
152 '=' => sub { bless [@{$_[0]}], ref $_[0] },
153 '""' => \&as_string,
154 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
155 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
156 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
157 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
158 'x=' => sub {
159 my $cur = $_[0] >= $_[1];
160 if (!defined $cur) {
161 if ($_[0] >= "all") {
162 $_[0] -= $_[1];
163 } else {
164 $_[0] += $_[1];
165 }
166 } elsif ($cur) {
167 $_[0] -= $_[1];
168 } else {
169 $_[0] /= $_[1];
170 }
171
172 $_[0]
173 },
174 'eq' => sub { "$_[0]" eq "$_[1]" },
175 'ne' => sub { "$_[0]" ne "$_[1]" },
176 ;
177}
178
179sub Crossfire::MoveType::new {
180 my ($class, $string) = @_;
181
182 my $mask;
183 my $value;
184
185 if ($string =~ /^\s*\d+\s*$/) {
186 $mask = MOVE_ALL;
187 $value = $string+0;
188 } else {
189 for (split /\s+/, lc $string) {
190 if (s/^-//) {
191 $mask |= $MOVE_TYPE{$_};
192 $value &= ~$MOVE_TYPE{$_};
193 } else {
194 $mask |= $MOVE_TYPE{$_};
195 $value |= $MOVE_TYPE{$_};
196 }
197 }
198 }
199
200 (bless [$mask, $value], $class)->normalise
201}
202
203sub Crossfire::MoveType::normalise {
204 my ($self) = @_;
205
206 if ($self->[0] & MOVE_ALL) {
207 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
208 $self->[0] &= $mask;
209 $self->[1] &= $mask;
210 }
211
212 $self->[1] &= $self->[0];
213
214 $self
215}
216
217sub Crossfire::MoveType::as_string {
218 my ($self) = @_;
219
220 my @res;
221
222 my ($mask, $value) = @$self;
223
224 for (@Crossfire::MOVE_TYPE) {
225 my $bit = $Crossfire::MOVE_TYPE{$_};
226 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
227 $mask &= ~$bit;
228 push @res, $value & $bit ? $_ : "-$_";
229 }
230 }
231
232 join " ", @res
233}
145 234
146sub load_ref($) { 235sub load_ref($) {
147 my ($path) = @_; 236 my ($path) = @_;
148 237
149 open my $fh, "<:raw:perlio", $path 238 open my $fh, "<:raw:perlio", $path
… …
199 while (my ($k, $v) = each %attack_mask) { 288 while (my ($k, $v) = each %attack_mask) {
200 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v; 289 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
201 } 290 }
202} 291}
203 292
293my %MATERIAL = reverse
294 paper => 1,
295 iron => 2,
296 glass => 4,
297 leather => 8,
298 wood => 16,
299 organic => 32,
300 stone => 64,
301 cloth => 128,
302 adamant => 256,
303 liquid => 512,
304 tin => 1024,
305 bone => 2048,
306 ice => 4096,
307
308 # guesses
309 runestone => 12,
310 bronze => 18,
311 "ancient wood" => 20,
312 glass => 36,
313 marble => 66,
314 ice => 68,
315 stone => 70,
316 stone => 80,
317 cloth => 136,
318 ironwood => 144,
319 adamantium => 258,
320 glacium => 260,
321 blood => 544,
322;
323
204# object as in "Object xxx", i.e. archetypes 324# object as in "Object xxx", i.e. archetypes
205sub normalize_object($) { 325sub normalize_object($) {
206 my ($ob) = @_; 326 my ($ob) = @_;
207 327
328 # convert material bitset to materialname, if possible
329 if (exists $ob->{material}) {
330 if (!$ob->{material}) {
331 delete $ob->{material};
332 } elsif (exists $ob->{materialname}) {
333 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
334 delete $ob->{material};
335 } else {
336 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
337 delete $ob->{material}; # assume materilname is more specific and nuke material
338 }
339 } elsif (my $name = $MATERIAL{$ob->{material}}) {
340 delete $ob->{material};
341 $ob->{materialname} = $name;
342 } else {
343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
344 }
345 }
346
347 # color_fg is used as default for magicmap if magicmap does not exist
348 $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg};
349
208 # nuke outdated or never supported fields 350 # nuke outdated or never supported fields
209 delete @$ob{qw( 351 delete @$ob{qw(
210 can_knockback can_parry can_impale can_cut can_dam_armour 352 can_knockback can_parry can_impale can_cut can_dam_armour
211 can_apply pass_thru can_pass_thru 353 can_apply pass_thru can_pass_thru color_bg color_fg
212 )}; 354 )};
213 355
214 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } 356 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
215 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } 357 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
216 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } 358 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
217 359
218 # convert movement strings to bitsets 360 # convert movement strings to bitsets
219 for my $attr (keys %FIELD_MOVEMENT) { 361 for my $attr (keys %FIELD_MOVEMENT) {
220 next unless exists $ob->{$attr}; 362 next unless exists $ob->{$attr};
221 363
222 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility 364 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
223
224 next if $ob->{$attr} =~ /^\d+$/;
225
226 my $flags = 0;
227
228 # assume list
229 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
230 $flags |= MOVE_WALK if $flag eq "walk";
231 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
232 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
233 $flags |= MOVE_FLYING if $flag eq "flying";
234 $flags |= MOVE_SWIM if $flag eq "swim";
235 $flags |= MOVE_BOAT if $flag eq "boat";
236 $flags |= MOVE_ALL if $flag eq "all";
237
238 $flags &= ~MOVE_WALK if $flag eq "-walk";
239 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
240 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
241 $flags &= ~MOVE_FLYING if $flag eq "-flying";
242 $flags &= ~MOVE_SWIM if $flag eq "-swim";
243 $flags &= ~MOVE_BOAT if $flag eq "-boat";
244 $flags &= ~MOVE_ALL if $flag eq "-all";
245 }
246
247 $ob->{$attr} = $flags;
248 } 365 }
249 366
250 # convert outdated movement flags to new movement sets 367 # convert outdated movement flags to new movement sets
251 if (defined (my $v = delete $ob->{no_pass})) { 368 if (defined (my $v = delete $ob->{no_pass})) {
252 $ob->{move_block} = $v ? MOVE_ALL : 0; 369 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
253 } 370 }
254 if (defined (my $v = delete $ob->{slow_move})) { 371 if (defined (my $v = delete $ob->{slow_move})) {
255 $ob->{move_slow} |= MOVE_WALK; 372 $ob->{move_slow} += "walk";
256 $ob->{move_slow_penalty} = $v; 373 $ob->{move_slow_penalty} = $v;
257 } 374 }
258 if (defined (my $v = delete $ob->{walk_on})) { 375 if (defined (my $v = delete $ob->{walk_on})) {
259 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; 376 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
260 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
261 : $ob->{move_on} & ~MOVE_WALK;
262 } 377 }
263 if (defined (my $v = delete $ob->{walk_off})) { 378 if (defined (my $v = delete $ob->{walk_off})) {
264 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; 379 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
265 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
266 : $ob->{move_off} & ~MOVE_WALK;
267 } 380 }
268 if (defined (my $v = delete $ob->{fly_on})) { 381 if (defined (my $v = delete $ob->{fly_on})) {
269 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; 382 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
270 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
271 : $ob->{move_on} & ~MOVE_FLY_LOW;
272 } 383 }
273 if (defined (my $v = delete $ob->{fly_off})) { 384 if (defined (my $v = delete $ob->{fly_off})) {
274 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; 385 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
275 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
276 : $ob->{move_off} & ~MOVE_FLY_LOW;
277 } 386 }
278 if (defined (my $v = delete $ob->{flying})) { 387 if (defined (my $v = delete $ob->{flying})) {
279 $ob->{move_type} = MOVE_ALL unless exists $ob->{move_type}; 388 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
280 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
281 : $ob->{move_type} & ~MOVE_FLY_LOW;
282 } 389 }
283 390
284 # convert idiotic event_xxx things into objects 391 # convert idiotic event_xxx things into objects
285 while (my ($event, $subtype) = each %EVENT_TYPE) { 392 while (my ($event, $subtype) = each %EVENT_TYPE) {
286 if (exists $ob->{"event_${event}_plugin"}) { 393 if (exists $ob->{"event_${event}_plugin"}) {
… …
384sub read_arch($;$) { 491sub read_arch($;$) {
385 my ($path, $toplevel) = @_; 492 my ($path, $toplevel) = @_;
386 493
387 my %arc; 494 my %arc;
388 my ($more, $prev); 495 my ($more, $prev);
496 my $comment;
389 497
390 open my $fh, "<:raw:perlio:utf8", $path 498 open my $fh, "<:raw:perlio:utf8", $path
391 or Carp::croak "$path: $!"; 499 or Carp::croak "$path: $!";
392 500
393# binmode $fh; 501# binmode $fh;
… …
397 505
398 while (<$fh>) { 506 while (<$fh>) {
399 s/\s+$//; 507 s/\s+$//;
400 if (/^end$/i) { 508 if (/^end$/i) {
401 last; 509 last;
510
402 } elsif (/^arch (\S+)$/i) { 511 } elsif (/^arch (\S+)$/i) {
403 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1); 512 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
513
404 } elsif (/^lore$/i) { 514 } elsif (/^lore$/i) {
405 while (<$fh>) { 515 while (<$fh>) {
406 last if /^endlore\s*$/i; 516 last if /^endlore\s*$/i;
407 $arc{lore} .= $_; 517 $arc{lore} .= $_;
408 } 518 }
… …
417 chomp; 527 chomp;
418 push @{ $arc{anim} }, $_; 528 push @{ $arc{anim} }, $_;
419 } 529 }
420 } elsif (/^(\S+)\s*(.*)$/) { 530 } elsif (/^(\S+)\s*(.*)$/) {
421 $arc{lc $1} = $2; 531 $arc{lc $1} = $2;
422 } elsif (/^\s*($|#)/) { 532 } elsif (/^\s*#/) {
533 $arc{_comment} .= "$_\n";
534
535 } elsif (/^\s*$/) {
423 # 536 #
424 } else { 537 } else {
425 warn "$path: unparsable line '$_' in arch $arc{_name}"; 538 warn "$path: unparsable line '$_' in arch $arc{_name}";
426 } 539 }
427 } 540 }
… …
433 s/\s+$//; 546 s/\s+$//;
434 if (/^more$/i) { 547 if (/^more$/i) {
435 $more = $prev; 548 $more = $prev;
436 } elsif (/^object (\S+)$/i) { 549 } elsif (/^object (\S+)$/i) {
437 my $name = $1; 550 my $name = $1;
438 my $arc = attr_thaw normalize_object $parse_block->(_name => $name); 551 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
552 undef $comment;
553 delete $arc{_comment} unless length $arc{_comment};
439 $arc->{_atype} = 'object'; 554 $arc->{_atype} = 'object';
440 555
441 if ($more) { 556 if ($more) {
442 $more->{more} = $arc; 557 $more->{more} = $arc;
443 } else { 558 } else {
… …
445 } 560 }
446 $prev = $arc; 561 $prev = $arc;
447 $more = undef; 562 $more = undef;
448 } elsif (/^arch (\S+)$/i) { 563 } elsif (/^arch (\S+)$/i) {
449 my $name = $1; 564 my $name = $1;
450 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name); 565 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
566 undef $comment;
567 delete $arc{_comment} unless length $arc{_comment};
451 $arc->{_atype} = 'arch'; 568 $arc->{_atype} = 'arch';
452 569
453 if ($more) { 570 if ($more) {
454 $more->{more} = $arc; 571 $more->{more} = $arc;
455 } else { 572 } else {
… …
464 push @{$toplevel->{lev_array}}, $_+0; 581 push @{$toplevel->{lev_array}}, $_+0;
465 } 582 }
466 } else { 583 } else {
467 $toplevel->{$1} = $2; 584 $toplevel->{$1} = $2;
468 } 585 }
586 } elsif (/^\s*#/) {
587 $comment .= "$_\n";
469 } elsif (/^\s*($|#)/) { 588 } elsif (/^\s*($|#)/) {
470 # 589 #
471 } else { 590 } else {
472 die "$path: unparseable top-level line '$_'"; 591 die "$path: unparseable top-level line '$_'";
473 } 592 }
… …
493 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 612 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
494 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 613 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
495 | (delete $a{attack_movement_bits_4_7}); 614 | (delete $a{attack_movement_bits_4_7});
496 } 615 }
497 616
617 if (my $comment = delete $a{_comment}) {
618 if ($comment =~ /[^\n\s#]/) {
619 $str .= $comment;
620 }
621 }
622
498 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n"; 623 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
499 624
500 my $inv = delete $a{inventory}; 625 my $inv = delete $a{inventory};
501 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some 626 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
502 my $anim = delete $a{anim}; 627 my $anim = delete $a{anim};
628
629 if ($a{_atype} eq 'object') {
630 $str .= join "\n", "anim", @$anim, "mina\n"
631 if $anim;
632 }
503 633
504 my @kv; 634 my @kv;
505 635
506 for ($a{_name} eq "map" 636 for ($a{_name} eq "map"
507 ? @Crossfire::FIELD_ORDER_MAP 637 ? @Crossfire::FIELD_ORDER_MAP
… …
519 my ($k, $v) = @$_; 649 my ($k, $v) = @$_;
520 650
521 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 651 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
522 $v =~ s/\n$//; 652 $v =~ s/\n$//;
523 $str .= "$k\n$v\n$end\n"; 653 $str .= "$k\n$v\n$end\n";
524 } elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
525 if ($v & ~Crossfire::MOVE_ALL or !$v) {
526 $str .= "$k $v\n";
527
528 } elsif ($v & Crossfire::MOVE_ALLBIT) {
529 $str .= "$k all";
530
531 $str .= " -walk" unless $v & Crossfire::MOVE_WALK;
532 $str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
533 $str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
534 $str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
535 $str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
536
537 $str .= "\n";
538
539 } else {
540 $str .= $k;
541
542 $str .= " walk" if $v & Crossfire::MOVE_WALK;
543 $str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
544 $str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
545 $str .= " swim" if $v & Crossfire::MOVE_SWIM;
546 $str .= " boat" if $v & Crossfire::MOVE_BOAT;
547
548 $str .= "\n";
549 }
550 } else { 654 } else {
551 $str .= "$k $v\n"; 655 $str .= "$k $v\n";
552 } 656 }
553 } 657 }
554 658
555 if ($inv) { 659 if ($inv) {
556 $append->($_) for @$inv; 660 $append->($_) for @$inv;
557 } 661 }
558 662
663 $str .= "end\n";
664
559 if ($a{_atype} eq 'object') { 665 if ($a{_atype} eq 'object') {
560 $str .= join "\n", "anim", @$anim, "mina\n" 666 if ($more) {
561 if $anim;
562 }
563
564 $str .= "end\n";
565
566 if (($a{_atype} eq 'object') && $more) {
567 $str .= "\nmore\n"; 667 $str .= "more\n";
568 $append->($more) if $more; 668 $append->($more) if $more;
669 } else {
670 $str .= "\n";
671 }
569 } 672 }
570 }; 673 };
571 674
572 for (@$arch) { 675 for (@$arch) {
573 $append->($_); 676 $append->($_);
… …
602 my ($a) = @_; 705 my ($a) = @_;
603 706
604 my $o = $ARCH{$a->{_name}} 707 my $o = $ARCH{$a->{_name}}
605 or return; 708 or return;
606 709
607 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 710 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
711 unless ($face) {
712 $face = $FACE{"blank.x11"}
608 or (warn "no face data found for arch '$a->{_name}'"), return; 713 or (warn "no face data found for arch '$a->{_name}'"), return;
714 }
609 715
610 if ($face->{w} > 1 || $face->{h} > 1) { 716 if ($face->{w} > 1 || $face->{h} > 1) {
611 # bigface 717 # bigface
612 return (0, 0, $face->{w} - 1, $face->{h} - 1); 718 return (0, 0, $face->{w} - 1, $face->{h} - 1);
613 719
… …
720 ]; 826 ];
721 827
722 $attr 828 $attr
723} 829}
724 830
725sub arch_edit_sections {
726# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
727# edit_type = 0;
728# else if (edit_type != 0) {
729# // all flags from 'check_type' must be unset in this arch because they get recalculated now
730# edit_type &= ~check_type;
731# }
732#
733# }
734# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
735# getAttributeValue("alive", defarch) == 1 &&
736# (getAttributeValue("monster", defarch) == 1 ||
737# getAttributeValue("generator", defarch) == 1)) {
738# // Monster: monsters/npcs/generators
739# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
740# }
741# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
742# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
743# // Walls
744# edit_type |= IGUIConstants.TILE_EDIT_WALL;
745# }
746# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
747# getAttributeValue("connected", defarch) != 0) {
748# // Connected Objects
749# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
750# }
751# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
752# arch_type == 66 || arch_type == 41 || arch_type == 95) {
753# // Exit: teleporter/exit/trapdoors
754# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
755# }
756# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
757# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
758# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
759# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
760# arch_type == 124 || arch_type == 130)) {
761# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
762# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
763# }
764# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
765# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
766# arch_type == 91 || arch_type == 21 || arch_type == 24) {
767# // Door: door/special door/gates + keys
768# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
769# }
770# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
771# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
772# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
773# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
774# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
775# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
776# arch_type == 122 || arch_type == 3)) {
777# // Equipment: weapons/armour/wands/rods
778# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
779# }
780#
781# return(edit_type);
782#
783#
784}
785
786sub cache_file($$&&) { 831sub cache_file($$&&) {
787 my ($src, $cache, $load, $create) = @_; 832 my ($src, $cache, $load, $create) = @_;
788 833
789 my ($size, $mtime) = (stat $src)[7,9] 834 my ($size, $mtime) = (stat $src)[7,9]
790 or Carp::croak "$src: $!"; 835 or Carp::croak "$src: $!";

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines