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.76 by root, Wed Oct 18 12:58:53 2006 UTC vs.
Revision 1.83 by root, Wed Feb 7 00:14:48 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.92'; 9our $VERSION = '0.96';
10 10
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
… …
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 blood => 544,
231;
232
204# object as in "Object xxx", i.e. archetypes 233# object as in "Object xxx", i.e. archetypes
205sub normalize_object($) { 234sub normalize_object($) {
206 my ($ob) = @_; 235 my ($ob) = @_;
236
237 # convert material bitset to materialname, if possible
238 if (exists $ob->{material}) {
239 if (!$ob->{material}) {
240 delete $ob->{material};
241 } elsif (exists $ob->{materialname}) {
242 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
243 delete $ob->{material};
244 } else {
245 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
246 delete $ob->{material}; # assume materilname is more specific and nuke material
247 }
248 } elsif (my $name = $MATERIAL{$ob->{material}}) {
249 delete $ob->{material};
250 $ob->{materialname} = $name;
251 } else {
252 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
253 }
254 }
207 255
208 # nuke outdated or never supported fields 256 # nuke outdated or never supported fields
209 delete @$ob{qw( 257 delete @$ob{qw(
210 can_knockback can_parry can_impale can_cut can_dam_armour 258 can_knockback can_parry can_impale can_cut can_dam_armour
211 can_apply pass_thru can_pass_thru 259 can_apply pass_thru can_pass_thru
… …
384sub read_arch($;$) { 432sub read_arch($;$) {
385 my ($path, $toplevel) = @_; 433 my ($path, $toplevel) = @_;
386 434
387 my %arc; 435 my %arc;
388 my ($more, $prev); 436 my ($more, $prev);
437 my $comment;
389 438
390 open my $fh, "<:raw:perlio:utf8", $path 439 open my $fh, "<:raw:perlio:utf8", $path
391 or Carp::croak "$path: $!"; 440 or Carp::croak "$path: $!";
392 441
393# binmode $fh; 442# binmode $fh;
… …
397 446
398 while (<$fh>) { 447 while (<$fh>) {
399 s/\s+$//; 448 s/\s+$//;
400 if (/^end$/i) { 449 if (/^end$/i) {
401 last; 450 last;
451
402 } elsif (/^arch (\S+)$/i) { 452 } elsif (/^arch (\S+)$/i) {
403 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1); 453 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
454
404 } elsif (/^lore$/i) { 455 } elsif (/^lore$/i) {
405 while (<$fh>) { 456 while (<$fh>) {
406 last if /^endlore\s*$/i; 457 last if /^endlore\s*$/i;
407 $arc{lore} .= $_; 458 $arc{lore} .= $_;
408 } 459 }
… …
417 chomp; 468 chomp;
418 push @{ $arc{anim} }, $_; 469 push @{ $arc{anim} }, $_;
419 } 470 }
420 } elsif (/^(\S+)\s*(.*)$/) { 471 } elsif (/^(\S+)\s*(.*)$/) {
421 $arc{lc $1} = $2; 472 $arc{lc $1} = $2;
422 } elsif (/^\s*($|#)/) { 473 } elsif (/^\s*#/) {
474 $arc{_comment} .= "$_\n";
475
476 } elsif (/^\s*$/) {
423 # 477 #
424 } else { 478 } else {
425 warn "$path: unparsable line '$_' in arch $arc{_name}"; 479 warn "$path: unparsable line '$_' in arch $arc{_name}";
426 } 480 }
427 } 481 }
… …
433 s/\s+$//; 487 s/\s+$//;
434 if (/^more$/i) { 488 if (/^more$/i) {
435 $more = $prev; 489 $more = $prev;
436 } elsif (/^object (\S+)$/i) { 490 } elsif (/^object (\S+)$/i) {
437 my $name = $1; 491 my $name = $1;
438 my $arc = attr_thaw normalize_object $parse_block->(_name => $name); 492 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
493 undef $comment;
494 delete $arc{_comment} unless length $arc{_comment};
439 $arc->{_atype} = 'object'; 495 $arc->{_atype} = 'object';
440 496
441 if ($more) { 497 if ($more) {
442 $more->{more} = $arc; 498 $more->{more} = $arc;
443 } else { 499 } else {
… …
445 } 501 }
446 $prev = $arc; 502 $prev = $arc;
447 $more = undef; 503 $more = undef;
448 } elsif (/^arch (\S+)$/i) { 504 } elsif (/^arch (\S+)$/i) {
449 my $name = $1; 505 my $name = $1;
450 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name); 506 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
507 undef $comment;
508 delete $arc{_comment} unless length $arc{_comment};
451 $arc->{_atype} = 'arch'; 509 $arc->{_atype} = 'arch';
452 510
453 if ($more) { 511 if ($more) {
454 $more->{more} = $arc; 512 $more->{more} = $arc;
455 } else { 513 } else {
… …
464 push @{$toplevel->{lev_array}}, $_+0; 522 push @{$toplevel->{lev_array}}, $_+0;
465 } 523 }
466 } else { 524 } else {
467 $toplevel->{$1} = $2; 525 $toplevel->{$1} = $2;
468 } 526 }
527 } elsif (/^\s*#/) {
528 $comment .= "$_\n";
469 } elsif (/^\s*($|#)/) { 529 } elsif (/^\s*($|#)/) {
470 # 530 #
471 } else { 531 } else {
472 die "$path: unparseable top-level line '$_'"; 532 die "$path: unparseable top-level line '$_'";
473 } 533 }
… …
493 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 553 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}) 554 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
495 | (delete $a{attack_movement_bits_4_7}); 555 | (delete $a{attack_movement_bits_4_7});
496 } 556 }
497 557
558 if (my $comment = delete $a{_comment}) {
559 if ($comment =~ /[^\n\s#]/) {
560 $str .= $comment;
561 }
562 }
563
498 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n"; 564 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
499 565
500 my $inv = delete $a{inventory}; 566 my $inv = delete $a{inventory};
501 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some 567 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
502 my $anim = delete $a{anim}; 568 my $anim = delete $a{anim};
503 569
504 my @kv; 570 my @kv;
505 571
… …
561 if $anim; 627 if $anim;
562 } 628 }
563 629
564 $str .= "end\n"; 630 $str .= "end\n";
565 631
566 if (($a{_atype} eq 'object') && $more) { 632 if ($a{_atype} eq 'object') {
633 if ($more) {
567 $str .= "\nmore\n"; 634 $str .= "more\n";
568 $append->($more) if $more; 635 $append->($more) if $more;
636 } else {
637 $str .= "\n";
638 }
569 } 639 }
570 }; 640 };
571 641
572 for (@$arch) { 642 for (@$arch) {
573 $append->($_); 643 $append->($_);
… …
602 my ($a) = @_; 672 my ($a) = @_;
603 673
604 my $o = $ARCH{$a->{_name}} 674 my $o = $ARCH{$a->{_name}}
605 or return; 675 or return;
606 676
607 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 677 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
678 unless ($face) {
679 $face = $FACE{"blank.x11"}
608 or (warn "no face data found for arch '$a->{_name}'"), return; 680 or (warn "no face data found for arch '$a->{_name}'"), return;
681 }
609 682
610 if ($face->{w} > 1 || $face->{h} > 1) { 683 if ($face->{w} > 1 || $face->{h} > 1) {
611 # bigface 684 # bigface
612 return (0, 0, $face->{w} - 1, $face->{h} - 1); 685 return (0, 0, $face->{w} - 1, $face->{h} - 1);
613 686

Diff Legend

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