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.78 by root, Sun Dec 3 01:02:05 2006 UTC vs.
Revision 1.84 by root, Wed Feb 7 00:22:34 2007 UTC

… …
199 while (my ($k, $v) = each %attack_mask) { 199 while (my ($k, $v) = each %attack_mask) {
200 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v; 200 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
201 } 201 }
202} 202}
203 203
204my %MATERIAL = reverse
205 paper => 1,
206 iron => 2,
207 glass => 4,
208 leather => 8,
209 wood => 16,
210 organic => 32,
211 stone => 64,
212 cloth => 128,
213 adamant => 256,
214 liquid => 512,
215 tin => 1024,
216 bone => 2048,
217 ice => 4096,
218
219 # guesses
220 runestone => 12,
221 bronze => 18,
222 "ancient wood" => 20,
223 glass => 36,
224 marble => 66,
225 ice => 68,
226 stone => 70,
227 stone => 80,
228 cloth => 136,
229 ironwood => 144,
230 glacium => 260,
231 blood => 544,
232;
233
204# object as in "Object xxx", i.e. archetypes 234# object as in "Object xxx", i.e. archetypes
205sub normalize_object($) { 235sub normalize_object($) {
206 my ($ob) = @_; 236 my ($ob) = @_;
237
238 # convert material bitset to materialname, if possible
239 if (exists $ob->{material}) {
240 if (!$ob->{material}) {
241 delete $ob->{material};
242 } elsif (exists $ob->{materialname}) {
243 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
244 delete $ob->{material};
245 } else {
246 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
247 delete $ob->{material}; # assume materilname is more specific and nuke material
248 }
249 } elsif (my $name = $MATERIAL{$ob->{material}}) {
250 delete $ob->{material};
251 $ob->{materialname} = $name;
252 } else {
253 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
254 }
255 }
207 256
208 # nuke outdated or never supported fields 257 # nuke outdated or never supported fields
209 delete @$ob{qw( 258 delete @$ob{qw(
210 can_knockback can_parry can_impale can_cut can_dam_armour 259 can_knockback can_parry can_impale can_cut can_dam_armour
211 can_apply pass_thru can_pass_thru 260 can_apply pass_thru can_pass_thru
… …
384sub read_arch($;$) { 433sub read_arch($;$) {
385 my ($path, $toplevel) = @_; 434 my ($path, $toplevel) = @_;
386 435
387 my %arc; 436 my %arc;
388 my ($more, $prev); 437 my ($more, $prev);
438 my $comment;
389 439
390 open my $fh, "<:raw:perlio:utf8", $path 440 open my $fh, "<:raw:perlio:utf8", $path
391 or Carp::croak "$path: $!"; 441 or Carp::croak "$path: $!";
392 442
393# binmode $fh; 443# binmode $fh;
… …
397 447
398 while (<$fh>) { 448 while (<$fh>) {
399 s/\s+$//; 449 s/\s+$//;
400 if (/^end$/i) { 450 if (/^end$/i) {
401 last; 451 last;
452
402 } elsif (/^arch (\S+)$/i) { 453 } elsif (/^arch (\S+)$/i) {
403 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1); 454 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
455
404 } elsif (/^lore$/i) { 456 } elsif (/^lore$/i) {
405 while (<$fh>) { 457 while (<$fh>) {
406 last if /^endlore\s*$/i; 458 last if /^endlore\s*$/i;
407 $arc{lore} .= $_; 459 $arc{lore} .= $_;
408 } 460 }
… …
417 chomp; 469 chomp;
418 push @{ $arc{anim} }, $_; 470 push @{ $arc{anim} }, $_;
419 } 471 }
420 } elsif (/^(\S+)\s*(.*)$/) { 472 } elsif (/^(\S+)\s*(.*)$/) {
421 $arc{lc $1} = $2; 473 $arc{lc $1} = $2;
422 } elsif (/^\s*($|#)/) { 474 } elsif (/^\s*#/) {
475 $arc{_comment} .= "$_\n";
476
477 } elsif (/^\s*$/) {
423 # 478 #
424 } else { 479 } else {
425 warn "$path: unparsable line '$_' in arch $arc{_name}"; 480 warn "$path: unparsable line '$_' in arch $arc{_name}";
426 } 481 }
427 } 482 }
… …
433 s/\s+$//; 488 s/\s+$//;
434 if (/^more$/i) { 489 if (/^more$/i) {
435 $more = $prev; 490 $more = $prev;
436 } elsif (/^object (\S+)$/i) { 491 } elsif (/^object (\S+)$/i) {
437 my $name = $1; 492 my $name = $1;
438 my $arc = attr_thaw normalize_object $parse_block->(_name => $name); 493 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
494 undef $comment;
495 delete $arc{_comment} unless length $arc{_comment};
439 $arc->{_atype} = 'object'; 496 $arc->{_atype} = 'object';
440 497
441 if ($more) { 498 if ($more) {
442 $more->{more} = $arc; 499 $more->{more} = $arc;
443 } else { 500 } else {
… …
445 } 502 }
446 $prev = $arc; 503 $prev = $arc;
447 $more = undef; 504 $more = undef;
448 } elsif (/^arch (\S+)$/i) { 505 } elsif (/^arch (\S+)$/i) {
449 my $name = $1; 506 my $name = $1;
450 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name); 507 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
508 undef $comment;
509 delete $arc{_comment} unless length $arc{_comment};
451 $arc->{_atype} = 'arch'; 510 $arc->{_atype} = 'arch';
452 511
453 if ($more) { 512 if ($more) {
454 $more->{more} = $arc; 513 $more->{more} = $arc;
455 } else { 514 } else {
… …
464 push @{$toplevel->{lev_array}}, $_+0; 523 push @{$toplevel->{lev_array}}, $_+0;
465 } 524 }
466 } else { 525 } else {
467 $toplevel->{$1} = $2; 526 $toplevel->{$1} = $2;
468 } 527 }
528 } elsif (/^\s*#/) {
529 $comment .= "$_\n";
469 } elsif (/^\s*($|#)/) { 530 } elsif (/^\s*($|#)/) {
470 # 531 #
471 } else { 532 } else {
472 die "$path: unparseable top-level line '$_'"; 533 die "$path: unparseable top-level line '$_'";
473 } 534 }
… …
493 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 554 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}) 555 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
495 | (delete $a{attack_movement_bits_4_7}); 556 | (delete $a{attack_movement_bits_4_7});
496 } 557 }
497 558
559 if (my $comment = delete $a{_comment}) {
560 if ($comment =~ /[^\n\s#]/) {
561 $str .= $comment;
562 }
563 }
564
498 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n"; 565 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
499 566
500 my $inv = delete $a{inventory}; 567 my $inv = delete $a{inventory};
501 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some 568 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
502 my $anim = delete $a{anim}; 569 my $anim = delete $a{anim};
503 570
504 my @kv; 571 my @kv;
505 572
… …
561 if $anim; 628 if $anim;
562 } 629 }
563 630
564 $str .= "end\n"; 631 $str .= "end\n";
565 632
566 if (($a{_atype} eq 'object') && $more) { 633 if ($a{_atype} eq 'object') {
634 if ($more) {
567 $str .= "\nmore\n"; 635 $str .= "more\n";
568 $append->($more) if $more; 636 $append->($more) if $more;
637 } else {
638 $str .= "\n";
639 }
569 } 640 }
570 }; 641 };
571 642
572 for (@$arch) { 643 for (@$arch) {
573 $append->($_); 644 $append->($_);
… …
602 my ($a) = @_; 673 my ($a) = @_;
603 674
604 my $o = $ARCH{$a->{_name}} 675 my $o = $ARCH{$a->{_name}}
605 or return; 676 or return;
606 677
607 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 678 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
679 unless ($face) {
680 $face = $FACE{"blank.x11"}
608 or (warn "no face data found for arch '$a->{_name}'"), return; 681 or (warn "no face data found for arch '$a->{_name}'"), return;
682 }
609 683
610 if ($face->{w} > 1 || $face->{h} > 1) { 684 if ($face->{w} > 1 || $face->{h} > 1) {
611 # bigface 685 # bigface
612 return (0, 0, $face->{w} - 1, $face->{h} - 1); 686 return (0, 0, $face->{w} - 1, $face->{h} - 1);
613 687

Diff Legend

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