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.57 by root, Thu Mar 23 08:55:54 2006 UTC vs.
Revision 1.91 by root, Sat Mar 3 19:06:03 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.1'; 9our $VERSION = '0.96';
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
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
24our $LIB = $ENV{CROSSFIRE_LIBDIR}; 36our $LIB = $ENV{CROSSFIRE_LIBDIR};
25 37
26our $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";
27 41
28mkdir $VARDIR, 0777; 42mkdir $VARDIR, 0777;
29 43
30sub TILESIZE (){ 32 } 44sub TILESIZE (){ 32 }
31 45
… …
37 msg => "endmsg", 51 msg => "endmsg",
38 lore => "endlore", 52 lore => "endlore",
39 maplore => "endmaplore", 53 maplore => "endmaplore",
40); 54);
41 55
56# movement bit type, PITA
57our %FIELD_MOVEMENT = map +($_ => undef),
58 qw(move_type move_block move_allow move_on move_off move_slow);
59
42# same as in server save routine, to (hopefully) be compatible 60# same as in server save routine, to (hopefully) be compatible
43# to the other editors. 61# to the other editors.
44our @FIELD_ORDER_MAP = (qw( 62our @FIELD_ORDER_MAP = (qw(
63 file_format_version
45 name swap_time reset_timeout fixed_resettime difficulty region 64 name attach swap_time reset_timeout fixed_resettime difficulty region
46 shopitems shopgreed shopmin shopmax shoprace 65 shopitems shopgreed shopmin shopmax shoprace
47 darkness width height enter_x enter_y msg maplore 66 darkness width height enter_x enter_y msg maplore
48 unique template 67 unique template
49 outdoor temp pressure humid windspeed winddir sky nosmooth 68 outdoor temp pressure humid windspeed winddir sky nosmooth
50 tile_path_1 tile_path_2 tile_path_3 tile_path_4 69 tile_path_1 tile_path_2 tile_path_3 tile_path_4
51)); 70));
52 71
53our @FIELD_ORDER = (qw( 72our @FIELD_ORDER = (qw(
54 elevation 73 elevation
55 74
56 name name_pl custom_name title race 75 name name_pl custom_name attach title race
57 slaying skill msg lore other_arch face 76 slaying skill msg lore other_arch face
58 #todo-events 77 #todo-events
59 animation is_animated 78 animation is_animated
60 Str Dex Con Wis Pow Cha Int 79 str dex con wis pow cha int
61 hp maxhp sp maxsp grace maxgrace 80 hp maxhp sp maxsp grace maxgrace
62 exp perm_exp expmul 81 exp perm_exp expmul
63 food dam luck wc ac x y speed speed_left move_state attack_movement 82 food dam luck wc ac x y speed speed_left move_state attack_movement
64 nrof level direction type subtype 83 nrof level direction type subtype attacktype
65 84
66 resist_physical resist_magic resist_fire resist_electricity 85 resist_physical resist_magic resist_fire resist_electricity
67 resist_cold resist_confusion resist_acid resist_drain 86 resist_cold resist_confusion resist_acid resist_drain
68 resist_weaponmagic resist_ghosthit resist_poison resist_slow 87 resist_weaponmagic resist_ghosthit resist_poison resist_slow
69 resist_paralyze resist_turn_undead resist_fear resist_cancellation 88 resist_paralyze resist_turn_undead resist_fear resist_cancellation
… …
98 117
99 body_range body_arm body_torso body_head body_neck body_skill 118 body_range body_arm body_torso body_head body_neck body_skill
100 body_finger body_shoulder body_foot body_hand body_wrist body_waist 119 body_finger body_shoulder body_foot body_hand body_wrist body_waist
101)); 120));
102 121
122our %EVENT_TYPE = (
123 apply => 1,
124 attack => 2,
125 death => 3,
126 drop => 4,
127 pickup => 5,
128 say => 6,
129 stop => 7,
130 time => 8,
131 throw => 9,
132 trigger => 10,
133 close => 11,
134 timer => 12,
135);
136
103sub MOVE_WALK (){ 0x01 } 137sub MOVE_WALK (){ 0x01 }
104sub MOVE_FLY_LOW (){ 0x02 } 138sub MOVE_FLY_LOW (){ 0x02 }
105sub MOVE_FLY_HIGH (){ 0x04 } 139sub MOVE_FLY_HIGH (){ 0x04 }
106sub MOVE_FLYING (){ 0x06 } 140sub MOVE_FLYING (){ 0x06 }
107sub MOVE_SWIM (){ 0x08 } 141sub MOVE_SWIM (){ 0x08 }
108sub MOVE_BOAT (){ 0x10 } 142sub MOVE_BOAT (){ 0x10 }
109sub MOVE_ALL (){ 0xff } 143sub MOVE_KNOWN (){ 0x1f } # all of above
144sub MOVE_ALL (){ 0x10000 } # very special value
145
146our %MOVE_TYPE = (
147 walk => MOVE_WALK,
148 fly_low => MOVE_FLY_LOW,
149 fly_high => MOVE_FLY_HIGH,
150 flying => MOVE_FLYING,
151 swim => MOVE_SWIM,
152 boat => MOVE_BOAT,
153 all => MOVE_ALL,
154);
155
156our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat);
157
158{
159 package Crossfire::MoveType;
160
161 use overload
162 '""' => \&as_string,
163 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
164 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
165 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
166 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 'x=' => sub {
168 my $cur = $_[0] >= $_[1];
169 if (!defined $cur) {
170 $_[0] += $_[1];
171 } elsif ($cur) {
172 $_[0] -= $_[1];
173 } else {
174 $_[0] /= $_[1];
175 }
176
177 $_[0]
178 },
179 'eq' => sub { "$_[0]" eq "$_[1]" },
180 'ne' => sub { "$_[0]" ne "$_[1]" },
181 ;
182}
183
184sub Crossfire::MoveType::new {
185 my ($class, $string) = @_;
186
187 my $mask;
188 my $value;
189
190 for (split /\s+/, lc $string) {
191 if (s/^-//) {
192 $mask |= $MOVE_TYPE{$_};
193 $value &= ~$MOVE_TYPE{$_};
194 } else {
195 $mask |= $MOVE_TYPE{$_};
196 $value |= $MOVE_TYPE{$_};
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}
110 234
111sub load_ref($) { 235sub load_ref($) {
112 my ($path) = @_; 236 my ($path) = @_;
113 237
114 open my $fh, "<", $path 238 open my $fh, "<:raw:perlio", $path
115 or die "$path: $!"; 239 or die "$path: $!";
116 binmode $fh;
117 local $/; 240 local $/;
118 241
119 thaw <$fh> 242 thaw <$fh>
120} 243}
121 244
122sub save_ref($$) { 245sub save_ref($$) {
123 my ($ref, $path) = @_; 246 my ($ref, $path) = @_;
124 247
125 open my $fh, ">", "$path~" 248 open my $fh, ">:raw:perlio", "$path~"
126 or die "$path~: $!"; 249 or die "$path~: $!";
127 binmode $fh;
128 print $fh freeze $ref; 250 print $fh freeze $ref;
129 close $fh; 251 close $fh;
130 rename "$path~", $path 252 rename "$path~", $path
131 or die "$path: $!"; 253 or die "$path: $!";
132} 254}
133 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
324# object as in "Object xxx", i.e. archetypes
134sub normalize_object($) { 325sub normalize_object($) {
135 my ($ob) = @_; 326 my ($ob) = @_;
136 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 # nuke outdated or never supported fields
137 delete $ob->{$_} for qw( 348 delete @$ob{qw(
138 can_knockback can_parry can_impale can_cut can_dam_armour 349 can_knockback can_parry can_impale can_cut can_dam_armour
139 can_apply pass_thru can_pass_thru 350 can_apply pass_thru can_pass_thru
140 ); 351 )};
141 352
142 for my $attr (qw(move_type move_block move_allow move_on move_off move_slow)) { 353 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
354 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
355 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
356
357 # convert movement strings to bitsets
358 for my $attr (keys %FIELD_MOVEMENT) {
143 next unless exists $ob->{$attr}; 359 next unless exists $ob->{$attr};
144 next if $ob->{$attr} =~ /^\d+$/;
145 360
146 my $flags = 0; 361 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
147
148 # assume list
149 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
150 $flags |= MOVE_WALK if $flag eq "walk";
151 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
152 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
153 $flags |= MOVE_FLYING if $flag eq "flying";
154 $flags |= MOVE_SWIM if $flag eq "swim";
155 $flags |= MOVE_BOAT if $flag eq "boat";
156 $flags |= MOVE_ALL if $flag eq "all";
157
158 $flags &= ~MOVE_WALK if $flag eq "-walk";
159 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
160 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
161 $flags &= ~MOVE_FLYING if $flag eq "-flying";
162 $flags &= ~MOVE_SWIM if $flag eq "-swim";
163 $flags &= ~MOVE_BOAT if $flag eq "-boat";
164 $flags &= ~MOVE_ALL if $flag eq "-all";
165 }
166
167 $ob->{$attr} = $flags;
168 } 362 }
169 363
364 # convert outdated movement flags to new movement sets
170 if (defined (my $v = delete $ob->{no_pass})) { 365 if (defined (my $v = delete $ob->{no_pass})) {
171 $ob->{move_block} = $v ? MOVE_ALL : 0; 366 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
172 } 367 }
173 if (defined (my $v = delete $ob->{slow_move})) { 368 if (defined (my $v = delete $ob->{slow_move})) {
174 $ob->{move_slow} |= MOVE_WALK; 369 $ob->{move_slow} += "walk";
175 $ob->{move_slow_penalty} = $v; 370 $ob->{move_slow_penalty} = $v;
176 } 371 }
177 if (defined (my $v = delete $ob->{walk_on})) { 372 if (defined (my $v = delete $ob->{walk_on})) {
178 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK 373 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
179 : $ob->{move_on} & ~MOVE_WALK;
180 } 374 }
181 if (defined (my $v = delete $ob->{walk_off})) { 375 if (defined (my $v = delete $ob->{walk_off})) {
182 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK 376 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
183 : $ob->{move_off} & ~MOVE_WALK;
184 } 377 }
185 if (defined (my $v = delete $ob->{fly_on})) { 378 if (defined (my $v = delete $ob->{fly_on})) {
186 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW 379 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
187 : $ob->{move_on} & ~MOVE_FLY_LOW;
188 } 380 }
189 if (defined (my $v = delete $ob->{fly_off})) { 381 if (defined (my $v = delete $ob->{fly_off})) {
190 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW 382 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
191 : $ob->{move_off} & ~MOVE_FLY_LOW;
192 } 383 }
193 if (defined (my $v = delete $ob->{flying})) { 384 if (defined (my $v = delete $ob->{flying})) {
194 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW 385 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
195 : $ob->{move_type} & ~MOVE_FLY_LOW;
196 } 386 }
387
388 # convert idiotic event_xxx things into objects
389 while (my ($event, $subtype) = each %EVENT_TYPE) {
390 if (exists $ob->{"event_${event}_plugin"}) {
391 push @{$ob->{inventory}}, {
392 _name => "event_$event",
393 title => delete $ob->{"event_${event}_plugin"},
394 slaying => delete $ob->{"event_${event}"},
395 name => delete $ob->{"event_${event}_options"},
396 };
397 }
398 }
399
400 # some archetypes had "+3" instead of the canonical "3", so fix
401 $ob->{dam} *= 1 if exists $ob->{dam};
197 402
198 $ob 403 $ob
199} 404}
200 405
406# arch as in "arch xxx", ie.. objects
201sub normalize_arch($) { 407sub normalize_arch($) {
202 my ($ob) = @_; 408 my ($ob) = @_;
203 409
204 normalize_object $ob; 410 normalize_object $ob;
205 411
… …
242 } 448 }
243 449
244 $ob 450 $ob
245} 451}
246 452
453sub attr_thaw($) {
454 my ($ob) = @_;
455
456 $ob->{attach} = from_json $ob->{attach}
457 if exists $ob->{attach};
458
459 $ob
460}
461
462sub attr_freeze($) {
463 my ($ob) = @_;
464
465 $ob->{attach} = Crossfire::to_json $ob->{attach}
466 if exists $ob->{attach};
467
468 $ob
469}
470
247sub read_pak($) { 471sub read_pak($) {
248 my ($path) = @_; 472 my ($path) = @_;
249 473
250 my %pak; 474 my %pak;
251 475
252 open my $fh, "<", $path 476 open my $fh, "<:raw:perlio", $path
253 or Carp::croak "$_[0]: $!"; 477 or Carp::croak "$_[0]: $!";
254 binmode $fh; 478 binmode $fh;
255 while (<$fh>) { 479 while (<$fh>) {
256 my ($type, $id, $len, $path) = split; 480 my ($type, $id, $len, $path) = split;
257 $path =~ s/.*\///; 481 $path =~ s/.*\///;
… …
259 } 483 }
260 484
261 \%pak 485 \%pak
262} 486}
263 487
264sub read_arch($) { 488sub read_arch($;$) {
265 my ($path) = @_; 489 my ($path, $toplevel) = @_;
266 490
267 my %arc; 491 my %arc;
268 my ($more, $prev); 492 my ($more, $prev);
493 my $comment;
269 494
270 open my $fh, "<", $path 495 open my $fh, "<:raw:perlio:utf8", $path
271 or Carp::croak "$path: $!"; 496 or Carp::croak "$path: $!";
272 497
273 binmode $fh; 498# binmode $fh;
274 499
275 my $parse_block; $parse_block = sub { 500 my $parse_block; $parse_block = sub {
276 my %arc = @_; 501 my %arc = @_;
277 502
278 while (<$fh>) { 503 while (<$fh>) {
279 s/\s+$//; 504 s/\s+$//;
280 if (/^end$/i) { 505 if (/^end$/i) {
281 last; 506 last;
507
282 } elsif (/^arch (\S+)$/i) { 508 } elsif (/^arch (\S+)$/i) {
283 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1); 509 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
510
284 } elsif (/^lore$/i) { 511 } elsif (/^lore$/i) {
285 while (<$fh>) { 512 while (<$fh>) {
286 last if /^endlore\s*$/i; 513 last if /^endlore\s*$/i;
287 $arc{lore} .= $_; 514 $arc{lore} .= $_;
288 } 515 }
289 } elsif (/^msg$/i) { 516 } elsif (/^msg$/i) {
290 while (<$fh>) { 517 while (<$fh>) {
291 last if /^endmsg\s*$/i; 518 last if /^endmsg\s*$/i;
292 $arc{msg} .= $_; 519 $arc{msg} .= $_;
293 } 520 }
521 } elsif (/^anim$/i) {
522 while (<$fh>) {
523 last if /^mina\s*$/i;
524 chomp;
525 push @{ $arc{anim} }, $_;
526 }
294 } elsif (/^(\S+)\s*(.*)$/) { 527 } elsif (/^(\S+)\s*(.*)$/) {
295 $arc{lc $1} = $2; 528 $arc{lc $1} = $2;
296 } elsif (/^\s*($|#)/) { 529 } elsif (/^\s*#/) {
530 $arc{_comment} .= "$_\n";
531
532 } elsif (/^\s*$/) {
297 # 533 #
298 } else { 534 } else {
299 warn "$path: unparsable line '$_' in arch $arc{_name}"; 535 warn "$path: unparsable line '$_' in arch $arc{_name}";
300 } 536 }
301 } 537 }
… …
307 s/\s+$//; 543 s/\s+$//;
308 if (/^more$/i) { 544 if (/^more$/i) {
309 $more = $prev; 545 $more = $prev;
310 } elsif (/^object (\S+)$/i) { 546 } elsif (/^object (\S+)$/i) {
311 my $name = $1; 547 my $name = $1;
312 my $arc = normalize_object $parse_block->(_name => $name); 548 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
549 undef $comment;
550 delete $arc{_comment} unless length $arc{_comment};
551 $arc->{_atype} = 'object';
313 552
314 if ($more) { 553 if ($more) {
315 $more->{more} = $arc; 554 $more->{more} = $arc;
316 } else { 555 } else {
317 $arc{$name} = $arc; 556 $arc{$name} = $arc;
318 } 557 }
319 $prev = $arc; 558 $prev = $arc;
320 $more = undef; 559 $more = undef;
321 } elsif (/^arch (\S+)$/i) { 560 } elsif (/^arch (\S+)$/i) {
322 my $name = $1; 561 my $name = $1;
323 my $arc = normalize_arch $parse_block->(_name => $name); 562 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
563 undef $comment;
564 delete $arc{_comment} unless length $arc{_comment};
565 $arc->{_atype} = 'arch';
324 566
325 if ($more) { 567 if ($more) {
326 $more->{more} = $arc; 568 $more->{more} = $arc;
327 } else { 569 } else {
328 push @{ $arc{arch} }, $arc; 570 push @{ $arc{arch} }, $arc;
329 } 571 }
330 $prev = $arc; 572 $prev = $arc;
331 $more = undef; 573 $more = undef;
574 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
575 if ($1 eq "lev_array") {
576 while (<$fh>) {
577 last if /^endplst\s*$/;
578 push @{$toplevel->{lev_array}}, $_+0;
579 }
580 } else {
581 $toplevel->{$1} = $2;
582 }
583 } elsif (/^\s*#/) {
584 $comment .= "$_\n";
332 } elsif (/^\s*($|#)/) { 585 } elsif (/^\s*($|#)/) {
333 # 586 #
334 } else { 587 } else {
335 warn "$path: unparseable top-level line '$_'"; 588 die "$path: unparseable top-level line '$_'";
336 } 589 }
337 } 590 }
338 591
339 undef $parse_block; # work around bug in perl not freeing $fh etc. 592 undef $parse_block; # work around bug in perl not freeing $fh etc.
340 593
341 \%arc 594 \%arc
595}
596
597sub archlist_to_string {
598 my ($arch) = @_;
599
600 my $str;
601
602 my $append; $append = sub {
603 my %a = %{$_[0]};
604
605 Crossfire::attr_freeze \%a;
606 Crossfire::normalize_arch \%a;
607
608 # undo the bit-split we did before
609 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
610 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
611 | (delete $a{attack_movement_bits_4_7});
612 }
613
614 if (my $comment = delete $a{_comment}) {
615 if ($comment =~ /[^\n\s#]/) {
616 $str .= $comment;
617 }
618 }
619
620 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
621
622 my $inv = delete $a{inventory};
623 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
624 my $anim = delete $a{anim};
625
626 if ($a{_atype} eq 'object') {
627 $str .= join "\n", "anim", @$anim, "mina\n"
628 if $anim;
629 }
630
631 my @kv;
632
633 for ($a{_name} eq "map"
634 ? @Crossfire::FIELD_ORDER_MAP
635 : @Crossfire::FIELD_ORDER) {
636 push @kv, [$_, delete $a{$_}]
637 if exists $a{$_};
638 }
639
640 for (sort keys %a) {
641 next if /^_/; # ignore our _-keys
642 push @kv, [$_, delete $a{$_}];
643 }
644
645 for (@kv) {
646 my ($k, $v) = @$_;
647
648 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
649 $v =~ s/\n$//;
650 $str .= "$k\n$v\n$end\n";
651 } else {
652 $str .= "$k $v\n";
653 }
654 }
655
656 if ($inv) {
657 $append->($_) for @$inv;
658 }
659
660 $str .= "end\n";
661
662 if ($a{_atype} eq 'object') {
663 if ($more) {
664 $str .= "more\n";
665 $append->($more) if $more;
666 } else {
667 $str .= "\n";
668 }
669 }
670 };
671
672 for (@$arch) {
673 $append->($_);
674 }
675
676 $str
342} 677}
343 678
344# put all archs into a hash with editor_face as it's key 679# put all archs into a hash with editor_face as it's key
345# NOTE: the arrays in the hash values are references to 680# NOTE: the arrays in the hash values are references to
346# the archs from $ARCH 681# the archs from $ARCH
347sub editor_archs { 682sub editor_archs {
348 my %paths; 683 my %paths;
349 684
350 for (keys %ARCH) { 685 for (keys %ARCH) {
351 my $arch = $ARCH{$_}; 686 my $arch = $ARCH{$_};
352 push @{$paths{$arch->{editor_folder}}}, \$arch; 687 push @{$paths{$arch->{editor_folder}}}, $arch;
353 } 688 }
354 689
355 \%paths 690 \%paths
356} 691}
357 692
… …
367 my ($a) = @_; 702 my ($a) = @_;
368 703
369 my $o = $ARCH{$a->{_name}} 704 my $o = $ARCH{$a->{_name}}
370 or return; 705 or return;
371 706
372 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} 707 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
708 unless ($face) {
709 $face = $FACE{"blank.x11"}
373 or (warn "no face data found for arch '$a->{_name}'"), return; 710 or (warn "no face data found for arch '$a->{_name}'"), return;
711 }
374 712
375 if ($face->{w} > 1 || $face->{h} > 1) { 713 if ($face->{w} > 1 || $face->{h} > 1) {
376 # bigface 714 # bigface
377 return (0, 0, $face->{w} - 1, $face->{h} - 1); 715 return (0, 0, $face->{w} - 1, $face->{h} - 1);
378 716
… …
422 my $type = $obj->{type} || $arch->{type}; 760 my $type = $obj->{type} || $arch->{type};
423 761
424 if ($type > 0) { 762 if ($type > 0) {
425 $root = $Crossfire::Data::ATTR{$type}; 763 $root = $Crossfire::Data::ATTR{$type};
426 } else { 764 } else {
765 my %a = (%$arch, %$obj);
766
767 if ($a{is_floor} && !$a{alive}) {
768 $root = $Crossfire::Data::TYPE{Floor};
769 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
770 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
771 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
772 $root = $Crossfire::Data::TYPE{Wall};
773 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
774 $root = $Crossfire::Data::TYPE{"Weak Wall"};
775 } else {
427 $root = $Crossfire::Data::TYPE{Misc}; 776 $root = $Crossfire::Data::TYPE{Misc};
428
429 type:
430 for (@Crossfire::Data::ATTR0) {
431 my $req = $_->{required}
432 or die "internal error: ATTR0 without 'required'";
433
434 keys %$req;
435 while (my ($k, $v) = each %$req) {
436 next type
437 unless $obj->{$k} == $v || $arch->{$k} == $v;
438 }
439
440 $root = $_;
441 } 777 }
442 } 778 }
443 779
444 my @import = ($root); 780 my @import = ($root);
445 781
… …
487 ]; 823 ];
488 824
489 $attr 825 $attr
490} 826}
491 827
492sub arch_edit_sections {
493# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
494# edit_type = 0;
495# else if (edit_type != 0) {
496# // all flags from 'check_type' must be unset in this arch because they get recalculated now
497# edit_type &= ~check_type;
498# }
499#
500# }
501# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
502# getAttributeValue("alive", defarch) == 1 &&
503# (getAttributeValue("monster", defarch) == 1 ||
504# getAttributeValue("generator", defarch) == 1)) {
505# // Monster: monsters/npcs/generators
506# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
507# }
508# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
509# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
510# // Walls
511# edit_type |= IGUIConstants.TILE_EDIT_WALL;
512# }
513# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
514# getAttributeValue("connected", defarch) != 0) {
515# // Connected Objects
516# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
517# }
518# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
519# arch_type == 66 || arch_type == 41 || arch_type == 95) {
520# // Exit: teleporter/exit/trapdoors
521# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
522# }
523# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
524# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
525# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
526# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
527# arch_type == 124 || arch_type == 130)) {
528# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
529# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
530# }
531# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
532# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
533# arch_type == 91 || arch_type == 21 || arch_type == 24) {
534# // Door: door/special door/gates + keys
535# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
536# }
537# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
538# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
539# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
540# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
541# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
542# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
543# arch_type == 122 || arch_type == 3)) {
544# // Equipment: weapons/armour/wands/rods
545# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
546# }
547#
548# return(edit_type);
549#
550#
551}
552
553sub cache_file($$&&) { 828sub cache_file($$&&) {
554 my ($src, $cache, $load, $create) = @_; 829 my ($src, $cache, $load, $create) = @_;
555 830
556 my ($size, $mtime) = (stat $src)[7,9] 831 my ($size, $mtime) = (stat $src)[7,9]
557 or Carp::croak "$src: $!"; 832 or Carp::croak "$src: $!";
… …
619 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 894 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
620 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 895 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
621 or die "$VARDIR/tilecache.png: $!"; 896 or die "$VARDIR/tilecache.png: $!";
622 *FACE = $_[0]; 897 *FACE = $_[0];
623 }, sub { 898 }, sub {
624 require File::Temp;
625
626 my $tile = read_pak "$LIB/crossfire.0"; 899 my $tile = read_pak "$LIB/crossfire.0";
627 900
628 my %cache; 901 my %cache;
629 902
630 my $idx = 0; 903 my $idx = 0;
631 904
632 for my $name (sort keys %$tile) { 905 for my $name (sort keys %$tile) {
633 my ($fh, $filename) = File::Temp::tempfile (); 906 my $pb = new Gtk2::Gdk::PixbufLoader;
634 print $fh $tile->{$name}; 907 $pb->write ($tile->{$name});
635 close $fh; 908 $pb->close;
636 my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename; 909 my $pb = $pb->get_pixbuf;
637 unlink $filename;
638 910
639 my $tile = $cache{$name} = { 911 my $tile = $cache{$name} = {
640 pb => $pb, 912 pb => $pb,
641 idx => $idx, 913 idx => $idx,
642 w => int $pb->get_width / TILESIZE, 914 w => int $pb->get_width / TILESIZE,
… …
660 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64); 932 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
661 } 933 }
662 } 934 }
663 } 935 }
664 936
665 $pb->save ("$VARDIR/tilecache.png", "png"); 937 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
666 938
667 \%cache 939 \%cache
668 }; 940 };
669} 941}
670 942

Diff Legend

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