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.70 by root, Sun Aug 27 16:33:19 2006 UTC vs.
Revision 1.85 by root, Wed Feb 7 00:44:18 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.9'; 9our $VERSION = '0.96';
10 10
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
… …
33 JSON::Syck::Dump $_[0] 33 JSON::Syck::Dump $_[0]
34} 34}
35 35
36our $LIB = $ENV{CROSSFIRE_LIBDIR}; 36our $LIB = $ENV{CROSSFIRE_LIBDIR};
37 37
38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire"; 38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
40 : File::Spec->tmpdir . "/crossfire";
39 41
40mkdir $VARDIR, 0777; 42mkdir $VARDIR, 0777;
41 43
42sub TILESIZE (){ 32 } 44sub TILESIZE (){ 32 }
43 45
… …
160 close $fh; 162 close $fh;
161 rename "$path~", $path 163 rename "$path~", $path
162 or die "$path: $!"; 164 or die "$path: $!";
163} 165}
164 166
167my %attack_mask = (
168 physical => 0x00000001,
169 magic => 0x00000002,
170 fire => 0x00000004,
171 electricity => 0x00000008,
172 cold => 0x00000010,
173 confusion => 0x00000020,
174 acid => 0x00000040,
175 drain => 0x00000080,
176 weaponmagic => 0x00000100,
177 ghosthit => 0x00000200,
178 poison => 0x00000400,
179 slow => 0x00000800,
180 paralyze => 0x00001000,
181 turn_undead => 0x00002000,
182 fear => 0x00004000,
183 cancellation => 0x00008000,
184 deplete => 0x00010000,
185 death => 0x00020000,
186 chaos => 0x00040000,
187 counterspell => 0x00080000,
188 godpower => 0x00100000,
189 holyword => 0x00200000,
190 blind => 0x00400000,
191 internal => 0x00800000,
192 life_stealing => 0x01000000,
193 disease => 0x02000000,
194);
195
196sub _add_resist($$$) {
197 my ($ob, $mask, $value) = @_;
198
199 while (my ($k, $v) = each %attack_mask) {
200 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
201 }
202}
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 adamantium => 258,
231 glacium => 260,
232 blood => 544,
233;
234
165# object as in "Object xxx", i.e. archetypes 235# object as in "Object xxx", i.e. archetypes
166sub normalize_object($) { 236sub normalize_object($) {
167 my ($ob) = @_; 237 my ($ob) = @_;
168 238
239 # convert material bitset to materialname, if possible
240 if (exists $ob->{material}) {
241 if (!$ob->{material}) {
242 delete $ob->{material};
243 } elsif (exists $ob->{materialname}) {
244 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
245 delete $ob->{material};
246 } else {
247 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
248 delete $ob->{material}; # assume materilname is more specific and nuke material
249 }
250 } elsif (my $name = $MATERIAL{$ob->{material}}) {
251 delete $ob->{material};
252 $ob->{materialname} = $name;
253 } else {
254 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
255 }
256 }
257
169 # nuke outdated or never supported fields 258 # nuke outdated or never supported fields
170 delete $ob->{$_} for qw( 259 delete @$ob{qw(
171 can_knockback can_parry can_impale can_cut can_dam_armour 260 can_knockback can_parry can_impale can_cut can_dam_armour
172 can_apply pass_thru can_pass_thru 261 can_apply pass_thru can_pass_thru
173 ); 262 )};
263
264 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
265 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
266 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
174 267
175 # convert movement strings to bitsets 268 # convert movement strings to bitsets
176 for my $attr (keys %FIELD_MOVEMENT) { 269 for my $attr (keys %FIELD_MOVEMENT) {
177 next unless exists $ob->{$attr}; 270 next unless exists $ob->{$attr};
178 271
… …
247 slaying => delete $ob->{"event_${event}"}, 340 slaying => delete $ob->{"event_${event}"},
248 name => delete $ob->{"event_${event}_options"}, 341 name => delete $ob->{"event_${event}_options"},
249 }; 342 };
250 } 343 }
251 } 344 }
345
346 # some archetypes had "+3" instead of the canonical "3", so fix
347 $ob->{dam} *= 1 if exists $ob->{dam};
252 348
253 $ob 349 $ob
254} 350}
255 351
256# arch as in "arch xxx", ie.. objects 352# arch as in "arch xxx", ie.. objects
… …
338sub read_arch($;$) { 434sub read_arch($;$) {
339 my ($path, $toplevel) = @_; 435 my ($path, $toplevel) = @_;
340 436
341 my %arc; 437 my %arc;
342 my ($more, $prev); 438 my ($more, $prev);
439 my $comment;
343 440
344 open my $fh, "<:raw:perlio:utf8", $path 441 open my $fh, "<:raw:perlio:utf8", $path
345 or Carp::croak "$path: $!"; 442 or Carp::croak "$path: $!";
346 443
347# binmode $fh; 444# binmode $fh;
… …
351 448
352 while (<$fh>) { 449 while (<$fh>) {
353 s/\s+$//; 450 s/\s+$//;
354 if (/^end$/i) { 451 if (/^end$/i) {
355 last; 452 last;
453
356 } elsif (/^arch (\S+)$/i) { 454 } elsif (/^arch (\S+)$/i) {
357 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1); 455 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
456
358 } elsif (/^lore$/i) { 457 } elsif (/^lore$/i) {
359 while (<$fh>) { 458 while (<$fh>) {
360 last if /^endlore\s*$/i; 459 last if /^endlore\s*$/i;
361 $arc{lore} .= $_; 460 $arc{lore} .= $_;
362 } 461 }
… …
371 chomp; 470 chomp;
372 push @{ $arc{anim} }, $_; 471 push @{ $arc{anim} }, $_;
373 } 472 }
374 } elsif (/^(\S+)\s*(.*)$/) { 473 } elsif (/^(\S+)\s*(.*)$/) {
375 $arc{lc $1} = $2; 474 $arc{lc $1} = $2;
376 } elsif (/^\s*($|#)/) { 475 } elsif (/^\s*#/) {
476 $arc{_comment} .= "$_\n";
477
478 } elsif (/^\s*$/) {
377 # 479 #
378 } else { 480 } else {
379 warn "$path: unparsable line '$_' in arch $arc{_name}"; 481 warn "$path: unparsable line '$_' in arch $arc{_name}";
380 } 482 }
381 } 483 }
… …
387 s/\s+$//; 489 s/\s+$//;
388 if (/^more$/i) { 490 if (/^more$/i) {
389 $more = $prev; 491 $more = $prev;
390 } elsif (/^object (\S+)$/i) { 492 } elsif (/^object (\S+)$/i) {
391 my $name = $1; 493 my $name = $1;
392 my $arc = attr_thaw normalize_object $parse_block->(_name => $name); 494 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
495 undef $comment;
496 delete $arc{_comment} unless length $arc{_comment};
497 $arc->{_atype} = 'object';
393 498
394 if ($more) { 499 if ($more) {
395 $more->{more} = $arc; 500 $more->{more} = $arc;
396 } else { 501 } else {
397 $arc{$name} = $arc; 502 $arc{$name} = $arc;
398 } 503 }
399 $prev = $arc; 504 $prev = $arc;
400 $more = undef; 505 $more = undef;
401 } elsif (/^arch (\S+)$/i) { 506 } elsif (/^arch (\S+)$/i) {
402 my $name = $1; 507 my $name = $1;
403 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name); 508 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
509 undef $comment;
510 delete $arc{_comment} unless length $arc{_comment};
511 $arc->{_atype} = 'arch';
404 512
405 if ($more) { 513 if ($more) {
406 $more->{more} = $arc; 514 $more->{more} = $arc;
407 } else { 515 } else {
408 push @{ $arc{arch} }, $arc; 516 push @{ $arc{arch} }, $arc;
… …
416 push @{$toplevel->{lev_array}}, $_+0; 524 push @{$toplevel->{lev_array}}, $_+0;
417 } 525 }
418 } else { 526 } else {
419 $toplevel->{$1} = $2; 527 $toplevel->{$1} = $2;
420 } 528 }
529 } elsif (/^\s*#/) {
530 $comment .= "$_\n";
421 } elsif (/^\s*($|#)/) { 531 } elsif (/^\s*($|#)/) {
422 # 532 #
423 } else { 533 } else {
424 die "$path: unparseable top-level line '$_'"; 534 die "$path: unparseable top-level line '$_'";
425 } 535 }
426 } 536 }
427 537
428 undef $parse_block; # work around bug in perl not freeing $fh etc. 538 undef $parse_block; # work around bug in perl not freeing $fh etc.
429 539
430 \%arc 540 \%arc
541}
542
543sub archlist_to_string {
544 my ($arch) = @_;
545
546 my $str;
547
548 my $append; $append = sub {
549 my %a = %{$_[0]};
550
551 Crossfire::attr_freeze \%a;
552 Crossfire::normalize_arch \%a;
553
554 # undo the bit-split we did before
555 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
556 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
557 | (delete $a{attack_movement_bits_4_7});
558 }
559
560 if (my $comment = delete $a{_comment}) {
561 if ($comment =~ /[^\n\s#]/) {
562 $str .= $comment;
563 }
564 }
565
566 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
567
568 my $inv = delete $a{inventory};
569 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
570 my $anim = delete $a{anim};
571
572 my @kv;
573
574 for ($a{_name} eq "map"
575 ? @Crossfire::FIELD_ORDER_MAP
576 : @Crossfire::FIELD_ORDER) {
577 push @kv, [$_, delete $a{$_}]
578 if exists $a{$_};
579 }
580
581 for (sort keys %a) {
582 next if /^_/; # ignore our _-keys
583 push @kv, [$_, delete $a{$_}];
584 }
585
586 for (@kv) {
587 my ($k, $v) = @$_;
588
589 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
590 $v =~ s/\n$//;
591 $str .= "$k\n$v\n$end\n";
592 } elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
593 if ($v & ~Crossfire::MOVE_ALL or !$v) {
594 $str .= "$k $v\n";
595
596 } elsif ($v & Crossfire::MOVE_ALLBIT) {
597 $str .= "$k all";
598
599 $str .= " -walk" unless $v & Crossfire::MOVE_WALK;
600 $str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
601 $str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
602 $str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
603 $str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
604
605 $str .= "\n";
606
607 } else {
608 $str .= $k;
609
610 $str .= " walk" if $v & Crossfire::MOVE_WALK;
611 $str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
612 $str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
613 $str .= " swim" if $v & Crossfire::MOVE_SWIM;
614 $str .= " boat" if $v & Crossfire::MOVE_BOAT;
615
616 $str .= "\n";
617 }
618 } else {
619 $str .= "$k $v\n";
620 }
621 }
622
623 if ($inv) {
624 $append->($_) for @$inv;
625 }
626
627 if ($a{_atype} eq 'object') {
628 $str .= join "\n", "anim", @$anim, "mina\n"
629 if $anim;
630 }
631
632 $str .= "end\n";
633
634 if ($a{_atype} eq 'object') {
635 if ($more) {
636 $str .= "more\n";
637 $append->($more) if $more;
638 } else {
639 $str .= "\n";
640 }
641 }
642 };
643
644 for (@$arch) {
645 $append->($_);
646 }
647
648 $str
431} 649}
432 650
433# put all archs into a hash with editor_face as it's key 651# put all archs into a hash with editor_face as it's key
434# NOTE: the arrays in the hash values are references to 652# NOTE: the arrays in the hash values are references to
435# the archs from $ARCH 653# the archs from $ARCH
… …
456 my ($a) = @_; 674 my ($a) = @_;
457 675
458 my $o = $ARCH{$a->{_name}} 676 my $o = $ARCH{$a->{_name}}
459 or return; 677 or return;
460 678
461 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 679 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
680 unless ($face) {
681 $face = $FACE{"blank.x11"}
462 or (warn "no face data found for arch '$a->{_name}'"), return; 682 or (warn "no face data found for arch '$a->{_name}'"), return;
683 }
463 684
464 if ($face->{w} > 1 || $face->{h} > 1) { 685 if ($face->{w} > 1 || $face->{h} > 1) {
465 # bigface 686 # bigface
466 return (0, 0, $face->{w} - 1, $face->{h} - 1); 687 return (0, 0, $face->{w} - 1, $face->{h} - 1);
467 688

Diff Legend

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