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.71 by elmex, Thu Aug 31 21:09:32 2006 UTC vs.
Revision 1.102 by elmex, Sun Apr 15 11:43:03 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.9'; 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" : File::Spec->tmpdir . "/crossfire"; 28our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
29 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
30 : File::Spec->tmpdir . "/crossfire";
39 31
40mkdir $VARDIR, 0777; 32mkdir $VARDIR, 0777;
41 33
42sub TILESIZE (){ 32 } 34sub TILESIZE (){ 32 }
43 35
… …
56 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);
57 49
58# same as in server save routine, to (hopefully) be compatible 50# same as in server save routine, to (hopefully) be compatible
59# to the other editors. 51# to the other editors.
60our @FIELD_ORDER_MAP = (qw( 52our @FIELD_ORDER_MAP = (qw(
53 file_format_version
61 name attach swap_time reset_timeout fixed_resettime difficulty region 54 name attach swap_time reset_timeout fixed_resettime difficulty region
62 shopitems shopgreed shopmin shopmax shoprace 55 shopitems shopgreed shopmin shopmax shoprace
63 darkness width height enter_x enter_y msg maplore 56 darkness width height enter_x enter_y msg maplore
64 unique template 57 unique template
65 outdoor temp pressure humid windspeed winddir sky nosmooth 58 outdoor temp pressure humid windspeed winddir sky nosmooth
… …
68 61
69our @FIELD_ORDER = (qw( 62our @FIELD_ORDER = (qw(
70 elevation 63 elevation
71 64
72 name name_pl custom_name attach title race 65 name name_pl custom_name attach title race
73 slaying skill msg lore other_arch face 66 slaying skill msg lore other_arch
74 #todo-events 67 is_animated animation face
75 animation is_animated 68 magicmap smoothlevel smoothface
76 str dex con wis pow cha int 69 str dex con wis pow cha int
77 hp maxhp sp maxsp grace maxgrace 70 hp maxhp sp maxsp grace maxgrace
78 exp perm_exp expmul 71 exp perm_exp expmul
79 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
80 nrof level direction type subtype attacktype 73 nrof level direction type subtype attacktype
… …
136sub MOVE_FLY_HIGH (){ 0x04 } 129sub MOVE_FLY_HIGH (){ 0x04 }
137sub MOVE_FLYING (){ 0x06 } 130sub MOVE_FLYING (){ 0x06 }
138sub MOVE_SWIM (){ 0x08 } 131sub MOVE_SWIM (){ 0x08 }
139sub MOVE_BOAT (){ 0x10 } 132sub MOVE_BOAT (){ 0x10 }
140sub MOVE_KNOWN (){ 0x1f } # all of above 133sub MOVE_KNOWN (){ 0x1f } # all of above
141sub MOVE_ALLBIT (){ 0x10000 }
142sub 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}
143 234
144sub load_ref($) { 235sub load_ref($) {
145 my ($path) = @_; 236 my ($path) = @_;
146 237
147 open my $fh, "<:raw:perlio", $path 238 open my $fh, "<:raw:perlio", $path
… …
160 close $fh; 251 close $fh;
161 rename "$path~", $path 252 rename "$path~", $path
162 or die "$path: $!"; 253 or die "$path: $!";
163} 254}
164 255
256my %attack_mask = (
257 physical => 0x00000001,
258 magic => 0x00000002,
259 fire => 0x00000004,
260 electricity => 0x00000008,
261 cold => 0x00000010,
262 confusion => 0x00000020,
263 acid => 0x00000040,
264 drain => 0x00000080,
265 weaponmagic => 0x00000100,
266 ghosthit => 0x00000200,
267 poison => 0x00000400,
268 slow => 0x00000800,
269 paralyze => 0x00001000,
270 turn_undead => 0x00002000,
271 fear => 0x00004000,
272 cancellation => 0x00008000,
273 deplete => 0x00010000,
274 death => 0x00020000,
275 chaos => 0x00040000,
276 counterspell => 0x00080000,
277 godpower => 0x00100000,
278 holyword => 0x00200000,
279 blind => 0x00400000,
280 internal => 0x00800000,
281 life_stealing => 0x01000000,
282 disease => 0x02000000,
283);
284
285sub _add_resist($$$) {
286 my ($ob, $mask, $value) = @_;
287
288 while (my ($k, $v) = each %attack_mask) {
289 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
290 }
291}
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
165# object as in "Object xxx", i.e. archetypes 324# object as in "Object xxx", i.e. archetypes
166sub normalize_object($) { 325sub normalize_object($) {
167 my ($ob) = @_; 326 my ($ob) = @_;
168 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
169 # nuke outdated or never supported fields 350 # nuke outdated or never supported fields
170 delete $ob->{$_} for qw( 351 delete @$ob{qw(
171 can_knockback can_parry can_impale can_cut can_dam_armour 352 can_knockback can_parry can_impale can_cut can_dam_armour
172 can_apply pass_thru can_pass_thru 353 can_apply pass_thru can_pass_thru color_bg color_fg
173 ); 354 )};
355
356 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
357 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
358 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
174 359
175 # convert movement strings to bitsets 360 # convert movement strings to bitsets
176 for my $attr (keys %FIELD_MOVEMENT) { 361 for my $attr (keys %FIELD_MOVEMENT) {
177 next unless exists $ob->{$attr}; 362 next unless exists $ob->{$attr};
178 363
179 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility 364 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
180
181 next if $ob->{$attr} =~ /^\d+$/;
182
183 my $flags = 0;
184
185 # assume list
186 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
187 $flags |= MOVE_WALK if $flag eq "walk";
188 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
189 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
190 $flags |= MOVE_FLYING if $flag eq "flying";
191 $flags |= MOVE_SWIM if $flag eq "swim";
192 $flags |= MOVE_BOAT if $flag eq "boat";
193 $flags |= MOVE_ALL if $flag eq "all";
194
195 $flags &= ~MOVE_WALK if $flag eq "-walk";
196 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
197 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
198 $flags &= ~MOVE_FLYING if $flag eq "-flying";
199 $flags &= ~MOVE_SWIM if $flag eq "-swim";
200 $flags &= ~MOVE_BOAT if $flag eq "-boat";
201 $flags &= ~MOVE_ALL if $flag eq "-all";
202 }
203
204 $ob->{$attr} = $flags;
205 } 365 }
206 366
207 # convert outdated movement flags to new movement sets 367 # convert outdated movement flags to new movement sets
208 if (defined (my $v = delete $ob->{no_pass})) { 368 if (defined (my $v = delete $ob->{no_pass})) {
209 $ob->{move_block} = $v ? MOVE_ALL : 0; 369 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
210 } 370 }
211 if (defined (my $v = delete $ob->{slow_move})) { 371 if (defined (my $v = delete $ob->{slow_move})) {
212 $ob->{move_slow} |= MOVE_WALK; 372 $ob->{move_slow} += "walk";
213 $ob->{move_slow_penalty} = $v; 373 $ob->{move_slow_penalty} = $v;
214 } 374 }
215 if (defined (my $v = delete $ob->{walk_on})) { 375 if (defined (my $v = delete $ob->{walk_on})) {
216 $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" }
217 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
218 : $ob->{move_on} & ~MOVE_WALK;
219 } 377 }
220 if (defined (my $v = delete $ob->{walk_off})) { 378 if (defined (my $v = delete $ob->{walk_off})) {
221 $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" }
222 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
223 : $ob->{move_off} & ~MOVE_WALK;
224 } 380 }
225 if (defined (my $v = delete $ob->{fly_on})) { 381 if (defined (my $v = delete $ob->{fly_on})) {
226 $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" }
227 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
228 : $ob->{move_on} & ~MOVE_FLY_LOW;
229 } 383 }
230 if (defined (my $v = delete $ob->{fly_off})) { 384 if (defined (my $v = delete $ob->{fly_off})) {
231 $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" }
232 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
233 : $ob->{move_off} & ~MOVE_FLY_LOW;
234 } 386 }
235 if (defined (my $v = delete $ob->{flying})) { 387 if (defined (my $v = delete $ob->{flying})) {
236 $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" }
237 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
238 : $ob->{move_type} & ~MOVE_FLY_LOW;
239 } 389 }
240 390
241 # convert idiotic event_xxx things into objects 391 # convert idiotic event_xxx things into objects
242 while (my ($event, $subtype) = each %EVENT_TYPE) { 392 while (my ($event, $subtype) = each %EVENT_TYPE) {
243 if (exists $ob->{"event_${event}_plugin"}) { 393 if (exists $ob->{"event_${event}_plugin"}) {
… …
247 slaying => delete $ob->{"event_${event}"}, 397 slaying => delete $ob->{"event_${event}"},
248 name => delete $ob->{"event_${event}_options"}, 398 name => delete $ob->{"event_${event}_options"},
249 }; 399 };
250 } 400 }
251 } 401 }
402
403 # some archetypes had "+3" instead of the canonical "3", so fix
404 $ob->{dam} *= 1 if exists $ob->{dam};
252 405
253 $ob 406 $ob
254} 407}
255 408
256# arch as in "arch xxx", ie.. objects 409# arch as in "arch xxx", ie.. objects
… …
338sub read_arch($;$) { 491sub read_arch($;$) {
339 my ($path, $toplevel) = @_; 492 my ($path, $toplevel) = @_;
340 493
341 my %arc; 494 my %arc;
342 my ($more, $prev); 495 my ($more, $prev);
496 my $comment;
343 497
344 open my $fh, "<:raw:perlio:utf8", $path 498 open my $fh, "<:raw:perlio:utf8", $path
345 or Carp::croak "$path: $!"; 499 or Carp::croak "$path: $!";
346 500
347# binmode $fh; 501# binmode $fh;
… …
351 505
352 while (<$fh>) { 506 while (<$fh>) {
353 s/\s+$//; 507 s/\s+$//;
354 if (/^end$/i) { 508 if (/^end$/i) {
355 last; 509 last;
510
356 } elsif (/^arch (\S+)$/i) { 511 } elsif (/^arch (\S+)$/i) {
357 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1); 512 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
513
358 } elsif (/^lore$/i) { 514 } elsif (/^lore$/i) {
359 while (<$fh>) { 515 while (<$fh>) {
360 last if /^endlore\s*$/i; 516 last if /^endlore\s*$/i;
361 $arc{lore} .= $_; 517 $arc{lore} .= $_;
362 } 518 }
… …
371 chomp; 527 chomp;
372 push @{ $arc{anim} }, $_; 528 push @{ $arc{anim} }, $_;
373 } 529 }
374 } elsif (/^(\S+)\s*(.*)$/) { 530 } elsif (/^(\S+)\s*(.*)$/) {
375 $arc{lc $1} = $2; 531 $arc{lc $1} = $2;
376 } elsif (/^\s*($|#)/) { 532 } elsif (/^\s*#/) {
533 $arc{_comment} .= "$_\n";
534
535 } elsif (/^\s*$/) {
377 # 536 #
378 } else { 537 } else {
379 warn "$path: unparsable line '$_' in arch $arc{_name}"; 538 warn "$path: unparsable line '$_' in arch $arc{_name}";
380 } 539 }
381 } 540 }
… …
387 s/\s+$//; 546 s/\s+$//;
388 if (/^more$/i) { 547 if (/^more$/i) {
389 $more = $prev; 548 $more = $prev;
390 } elsif (/^object (\S+)$/i) { 549 } elsif (/^object (\S+)$/i) {
391 my $name = $1; 550 my $name = $1;
392 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};
393 $arc->{_atype} = 'object'; 554 $arc->{_atype} = 'object';
394 555
395 if ($more) { 556 if ($more) {
396 $more->{more} = $arc; 557 $more->{more} = $arc;
397 } else { 558 } else {
… …
399 } 560 }
400 $prev = $arc; 561 $prev = $arc;
401 $more = undef; 562 $more = undef;
402 } elsif (/^arch (\S+)$/i) { 563 } elsif (/^arch (\S+)$/i) {
403 my $name = $1; 564 my $name = $1;
404 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};
405 $arc->{_atype} = 'arch'; 568 $arc->{_atype} = 'arch';
406 569
407 if ($more) { 570 if ($more) {
408 $more->{more} = $arc; 571 $more->{more} = $arc;
409 } else { 572 } else {
… …
418 push @{$toplevel->{lev_array}}, $_+0; 581 push @{$toplevel->{lev_array}}, $_+0;
419 } 582 }
420 } else { 583 } else {
421 $toplevel->{$1} = $2; 584 $toplevel->{$1} = $2;
422 } 585 }
586 } elsif (/^\s*#/) {
587 $comment .= "$_\n";
423 } elsif (/^\s*($|#)/) { 588 } elsif (/^\s*($|#)/) {
424 # 589 #
425 } else { 590 } else {
426 die "$path: unparseable top-level line '$_'"; 591 die "$path: unparseable top-level line '$_'";
427 } 592 }
… …
447 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}) {
448 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 613 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
449 | (delete $a{attack_movement_bits_4_7}); 614 | (delete $a{attack_movement_bits_4_7});
450 } 615 }
451 616
617 if (my $comment = delete $a{_comment}) {
618 if ($comment =~ /[^\n\s#]/) {
619 $str .= $comment;
620 }
621 }
622
452 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n"; 623 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
453 624
454 my $inv = delete $a{inventory}; 625 my $inv = delete $a{inventory};
455 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
456 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 }
457 633
458 my @kv; 634 my @kv;
459 635
460 for ($a{_name} eq "map" 636 for ($a{_name} eq "map"
461 ? @Crossfire::FIELD_ORDER_MAP 637 ? @Crossfire::FIELD_ORDER_MAP
… …
473 my ($k, $v) = @$_; 649 my ($k, $v) = @$_;
474 650
475 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 651 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
476 $v =~ s/\n$//; 652 $v =~ s/\n$//;
477 $str .= "$k\n$v\n$end\n"; 653 $str .= "$k\n$v\n$end\n";
478 } elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
479 if ($v & ~Crossfire::MOVE_ALL or !$v) {
480 $str .= "$k $v\n";
481
482 } elsif ($v & Crossfire::MOVE_ALLBIT) {
483 $str .= "$k all";
484
485 $str .= " -walk" unless $v & Crossfire::MOVE_WALK;
486 $str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
487 $str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
488 $str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
489 $str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
490
491 $str .= "\n";
492
493 } else {
494 $str .= $k;
495
496 $str .= " walk" if $v & Crossfire::MOVE_WALK;
497 $str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
498 $str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
499 $str .= " swim" if $v & Crossfire::MOVE_SWIM;
500 $str .= " boat" if $v & Crossfire::MOVE_BOAT;
501
502 $str .= "\n";
503 }
504 } else { 654 } else {
505 $str .= "$k $v\n"; 655 $str .= "$k $v\n";
506 } 656 }
507 } 657 }
508 658
509 if ($inv) { 659 if ($inv) {
510 $append->($_) for @$inv; 660 $append->($_) for @$inv;
511 } 661 }
512 662
663 $str .= "end\n";
664
513 if ($a{_atype} eq 'object') { 665 if ($a{_atype} eq 'object') {
514 $str .= join "\n", "anim", @$anim, "mina\n" 666 if ($more) {
515 if $anim;
516 }
517
518 $str .= "end\n";
519
520 if (($a{_atype} eq 'object') && $more) {
521 $str .= "\nmore\n"; 667 $str .= "more\n";
522 $append->($more) if $more; 668 $append->($more) if $more;
669 } else {
670 $str .= "\n";
671 }
523 } 672 }
524 }; 673 };
525 674
526 for (@$arch) { 675 for (@$arch) {
527 $append->($_); 676 $append->($_);
… …
556 my ($a) = @_; 705 my ($a) = @_;
557 706
558 my $o = $ARCH{$a->{_name}} 707 my $o = $ARCH{$a->{_name}}
559 or return; 708 or return;
560 709
561 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"}
562 or (warn "no face data found for arch '$a->{_name}'"), return; 713 or (warn "no face data found for arch '$a->{_name}'"), return;
714 }
563 715
564 if ($face->{w} > 1 || $face->{h} > 1) { 716 if ($face->{w} > 1 || $face->{h} > 1) {
565 # bigface 717 # bigface
566 return (0, 0, $face->{w} - 1, $face->{h} - 1); 718 return (0, 0, $face->{w} - 1, $face->{h} - 1);
567 719
… …
674 ]; 826 ];
675 827
676 $attr 828 $attr
677} 829}
678 830
679sub arch_edit_sections {
680# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
681# edit_type = 0;
682# else if (edit_type != 0) {
683# // all flags from 'check_type' must be unset in this arch because they get recalculated now
684# edit_type &= ~check_type;
685# }
686#
687# }
688# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
689# getAttributeValue("alive", defarch) == 1 &&
690# (getAttributeValue("monster", defarch) == 1 ||
691# getAttributeValue("generator", defarch) == 1)) {
692# // Monster: monsters/npcs/generators
693# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
694# }
695# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
696# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
697# // Walls
698# edit_type |= IGUIConstants.TILE_EDIT_WALL;
699# }
700# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
701# getAttributeValue("connected", defarch) != 0) {
702# // Connected Objects
703# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
704# }
705# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
706# arch_type == 66 || arch_type == 41 || arch_type == 95) {
707# // Exit: teleporter/exit/trapdoors
708# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
709# }
710# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
711# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
712# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
713# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
714# arch_type == 124 || arch_type == 130)) {
715# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
716# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
717# }
718# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
719# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
720# arch_type == 91 || arch_type == 21 || arch_type == 24) {
721# // Door: door/special door/gates + keys
722# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
723# }
724# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
725# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
726# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
727# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
728# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
729# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
730# arch_type == 122 || arch_type == 3)) {
731# // Equipment: weapons/armour/wands/rods
732# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
733# }
734#
735# return(edit_type);
736#
737#
738}
739
740sub cache_file($$&&) { 831sub cache_file($$&&) {
741 my ($src, $cache, $load, $create) = @_; 832 my ($src, $cache, $load, $create) = @_;
742 833
743 my ($size, $mtime) = (stat $src)[7,9] 834 my ($size, $mtime) = (stat $src)[7,9]
744 or Carp::croak "$src: $!"; 835 or Carp::croak "$src: $!";
… …
792 }, sub { 883 }, sub {
793 read_arch "$LIB/archetypes" 884 read_arch "$LIB/archetypes"
794 }; 885 };
795} 886}
796 887
888sub construct_tilecache_pb {
889 my ($idx, $cache) = @_;
890
891 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
892
893 while (my ($name, $tile) = each %$cache) {
894 my $tpb = delete $tile->{pb};
895 my $ofs = $tile->{idx};
896
897 for my $x (0 .. $tile->{w} - 1) {
898 for my $y (0 .. $tile->{h} - 1) {
899 my $idx = $ofs + $x + $y * $tile->{w};
900 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
901 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
902 }
903 }
904 }
905
906 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
907
908 $cache
909}
910
911sub use_tilecache {
912 my ($face) = @_;
913 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
914 or die "$VARDIR/tilecache.png: $!";
915 *FACE = $_[0];
916}
917
797=item load_tilecache 918=item load_tilecache
798 919
799(Re-)Load %TILE and %FACE. 920(Re-)Load %TILE and %FACE.
800 921
801=cut 922=cut
802 923
803sub load_tilecache() { 924sub load_tilecache() {
804 require Gtk2; 925 require Gtk2;
805 926
927 if (-e "$LIB/crossfire.0") { # Crossfire1 version
806 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 928 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
807 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 929 sub {
808 or die "$VARDIR/tilecache.png: $!";
809 *FACE = $_[0];
810 }, sub {
811 my $tile = read_pak "$LIB/crossfire.0"; 930 my $tile = read_pak "$LIB/crossfire.0";
812 931
813 my %cache; 932 my %cache;
814 933
815 my $idx = 0; 934 my $idx = 0;
816 935
817 for my $name (sort keys %$tile) { 936 for my $name (sort keys %$tile) {
818 my $pb = new Gtk2::Gdk::PixbufLoader; 937 my $pb = new Gtk2::Gdk::PixbufLoader;
819 $pb->write ($tile->{$name}); 938 $pb->write ($tile->{$name});
820 $pb->close; 939 $pb->close;
821 my $pb = $pb->get_pixbuf; 940 my $pb = $pb->get_pixbuf;
822 941
823 my $tile = $cache{$name} = { 942 my $tile = $cache{$name} = {
824 pb => $pb, 943 pb => $pb,
825 idx => $idx, 944 idx => $idx,
826 w => int $pb->get_width / TILESIZE, 945 w => int $pb->get_width / TILESIZE,
827 h => int $pb->get_height / TILESIZE, 946 h => int $pb->get_height / TILESIZE,
947 };
948
949 $idx += $tile->{w} * $tile->{h};
950 }
951
952 construct_tilecache_pb $idx, \%cache;
953
954 \%cache
828 }; 955 };
956
957 } else { # Crossfire+ version
958 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
959 sub {
960 my %cache;
961 my $facedata = Storable::retrieve "$LIB/facedata";
962
963 $facedata->{version} == 2
964 or die "$LIB/facedata: version mismatch, cannot proceed.";
965
966 my $faces = $facedata->{faceinfo};
967 my $idx = 0;
968
969 for (sort keys %$faces) {
970 my ($face, $info) = ($_, $faces->{$_});
971
972 my $pb = new Gtk2::Gdk::PixbufLoader;
973 $pb->write ($info->{data32});
974 $pb->close;
975 my $pb = $pb->get_pixbuf;
976
977 my $tile = $cache{$face} = {
978 pb => $pb,
979 idx => $idx,
980 w => int $pb->get_width / TILESIZE,
981 h => int $pb->get_height / TILESIZE,
829 982 };
830 983
831 $idx += $tile->{w} * $tile->{h}; 984 $idx += $tile->{w} * $tile->{h};
832 }
833
834 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
835
836 while (my ($name, $tile) = each %cache) {
837 my $tpb = delete $tile->{pb};
838 my $ofs = $tile->{idx};
839
840 for my $x (0 .. $tile->{w} - 1) {
841 for my $y (0 .. $tile->{h} - 1) {
842 my $idx = $ofs + $x + $y * $tile->{w};
843 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
844 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
845 } 985 }
986
987 construct_tilecache_pb $idx, \%cache;
988
989 \%cache
846 } 990 };
847 }
848
849 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
850
851 \%cache
852 }; 991 }
853} 992}
854 993
855=head1 AUTHOR 994=head1 AUTHOR
856 995
857 Marc Lehmann <schmorp@schmorp.de> 996 Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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