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.56 by root, Thu Mar 23 07:33:16 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(
73 elevation
74
54 name name_pl custom_name title race 75 name name_pl custom_name attach title race
55 slaying skill msg lore other_arch face 76 slaying skill msg lore other_arch face
56 #todo-events 77 #todo-events
57 animation is_animated 78 animation is_animated
58 Str Dex Con Wis Pow Cha Int 79 str dex con wis pow cha int
59 hp maxhp sp maxsp grace maxgrace 80 hp maxhp sp maxsp grace maxgrace
60 exp perm_exp expmul 81 exp perm_exp expmul
61 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
62 nrof level direction type subtype 83 nrof level direction type subtype attacktype
63 84
64 resist_physical resist_magic resist_fire resist_electricity 85 resist_physical resist_magic resist_fire resist_electricity
65 resist_cold resist_confusion resist_acid resist_drain 86 resist_cold resist_confusion resist_acid resist_drain
66 resist_weaponmagic resist_ghosthit resist_poison resist_slow 87 resist_weaponmagic resist_ghosthit resist_poison resist_slow
67 resist_paralyze resist_turn_undead resist_fear resist_cancellation 88 resist_paralyze resist_turn_undead resist_fear resist_cancellation
… …
96 117
97 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
98 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
99)); 120));
100 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
101sub MOVE_WALK (){ 0x01 } 137sub MOVE_WALK (){ 0x01 }
102sub MOVE_FLY_LOW (){ 0x02 } 138sub MOVE_FLY_LOW (){ 0x02 }
103sub MOVE_FLY_HIGH (){ 0x04 } 139sub MOVE_FLY_HIGH (){ 0x04 }
104sub MOVE_FLYING (){ 0x06 } 140sub MOVE_FLYING (){ 0x06 }
105sub MOVE_SWIM (){ 0x08 } 141sub MOVE_SWIM (){ 0x08 }
106sub MOVE_BOAT (){ 0x10 } 142sub MOVE_BOAT (){ 0x10 }
107sub 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}
108 234
109sub load_ref($) { 235sub load_ref($) {
110 my ($path) = @_; 236 my ($path) = @_;
111 237
112 open my $fh, "<", $path 238 open my $fh, "<:raw:perlio", $path
113 or die "$path: $!"; 239 or die "$path: $!";
114 binmode $fh;
115 local $/; 240 local $/;
116 241
117 thaw <$fh> 242 thaw <$fh>
118} 243}
119 244
120sub save_ref($$) { 245sub save_ref($$) {
121 my ($ref, $path) = @_; 246 my ($ref, $path) = @_;
122 247
123 open my $fh, ">", "$path~" 248 open my $fh, ">:raw:perlio", "$path~"
124 or die "$path~: $!"; 249 or die "$path~: $!";
125 binmode $fh;
126 print $fh freeze $ref; 250 print $fh freeze $ref;
127 close $fh; 251 close $fh;
128 rename "$path~", $path 252 rename "$path~", $path
129 or die "$path: $!"; 253 or die "$path: $!";
130} 254}
131 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
132sub normalize_object($) { 325sub normalize_object($) {
133 my ($ob) = @_; 326 my ($ob) = @_;
134 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
135 delete $ob->{$_} for qw( 348 delete @$ob{qw(
136 can_knockback can_parry can_impale can_cut can_dam_armour 349 can_knockback can_parry can_impale can_cut can_dam_armour
137 can_apply pass_thru can_pass_thru 350 can_apply pass_thru can_pass_thru
138 ); 351 )};
139 352
140 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) {
141 next unless exists $ob->{$attr}; 359 next unless exists $ob->{$attr};
142 next if $ob->{$attr} =~ /^\d+$/;
143 360
144 my $flags = 0; 361 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
145
146 # assume list
147 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
148 $flags |= MOVE_WALK if $flag eq "walk";
149 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
150 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
151 $flags |= MOVE_FLYING if $flag eq "flying";
152 $flags |= MOVE_SWIM if $flag eq "swim";
153 $flags |= MOVE_BOAT if $flag eq "boat";
154 $flags |= MOVE_ALL if $flag eq "all";
155
156 $flags &= ~MOVE_WALK if $flag eq "-walk";
157 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
158 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
159 $flags &= ~MOVE_FLYING if $flag eq "-flying";
160 $flags &= ~MOVE_SWIM if $flag eq "-swim";
161 $flags &= ~MOVE_BOAT if $flag eq "-boat";
162 $flags &= ~MOVE_ALL if $flag eq "-all";
163 }
164
165 $ob->{$attr} = $flags;
166 } 362 }
167 363
364 # convert outdated movement flags to new movement sets
168 if (defined (my $v = delete $ob->{no_pass})) { 365 if (defined (my $v = delete $ob->{no_pass})) {
169 $ob->{move_block} = $v ? MOVE_ALL : 0; 366 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
170 } 367 }
171 if (defined (my $v = delete $ob->{slow_move})) { 368 if (defined (my $v = delete $ob->{slow_move})) {
172 $ob->{move_slow} |= MOVE_WALK; 369 $ob->{move_slow} += "walk";
173 $ob->{move_slow_penalty} = $v; 370 $ob->{move_slow_penalty} = $v;
174 } 371 }
175 if (defined (my $v = delete $ob->{walk_on})) { 372 if (defined (my $v = delete $ob->{walk_on})) {
176 $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" }
177 : $ob->{move_on} & ~MOVE_WALK;
178 } 374 }
179 if (defined (my $v = delete $ob->{walk_off})) { 375 if (defined (my $v = delete $ob->{walk_off})) {
180 $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" }
181 : $ob->{move_off} & ~MOVE_WALK;
182 } 377 }
183 if (defined (my $v = delete $ob->{fly_on})) { 378 if (defined (my $v = delete $ob->{fly_on})) {
184 $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" }
185 : $ob->{move_on} & ~MOVE_FLY_LOW;
186 } 380 }
187 if (defined (my $v = delete $ob->{fly_off})) { 381 if (defined (my $v = delete $ob->{fly_off})) {
188 $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" }
189 : $ob->{move_off} & ~MOVE_FLY_LOW;
190 } 383 }
191 if (defined (my $v = delete $ob->{flying})) { 384 if (defined (my $v = delete $ob->{flying})) {
192 $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" }
193 : $ob->{move_type} & ~MOVE_FLY_LOW;
194 } 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};
195 402
196 $ob 403 $ob
197} 404}
198 405
406# arch as in "arch xxx", ie.. objects
199sub normalize_arch($) { 407sub normalize_arch($) {
200 my ($ob) = @_; 408 my ($ob) = @_;
201 409
202 normalize_object $ob; 410 normalize_object $ob;
203 411
… …
230 delete $ob->{$k}; 438 delete $ob->{$k};
231 } 439 }
232 } 440 }
233 } 441 }
234 442
443 # a speciality for the editor
444 if (exists $ob->{attack_movement}) {
445 my $am = delete $ob->{attack_movement};
446 $ob->{attack_movement_bits_0_3} = $am & 15;
447 $ob->{attack_movement_bits_4_7} = $am & 240;
448 }
449
450 $ob
451}
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
235 $ob 468 $ob
236} 469}
237 470
238sub read_pak($) { 471sub read_pak($) {
239 my ($path) = @_; 472 my ($path) = @_;
240 473
241 my %pak; 474 my %pak;
242 475
243 open my $fh, "<", $path 476 open my $fh, "<:raw:perlio", $path
244 or Carp::croak "$_[0]: $!"; 477 or Carp::croak "$_[0]: $!";
245 binmode $fh; 478 binmode $fh;
246 while (<$fh>) { 479 while (<$fh>) {
247 my ($type, $id, $len, $path) = split; 480 my ($type, $id, $len, $path) = split;
248 $path =~ s/.*\///; 481 $path =~ s/.*\///;
… …
250 } 483 }
251 484
252 \%pak 485 \%pak
253} 486}
254 487
255sub read_arch($) { 488sub read_arch($;$) {
256 my ($path) = @_; 489 my ($path, $toplevel) = @_;
257 490
258 my %arc; 491 my %arc;
259 my ($more, $prev); 492 my ($more, $prev);
493 my $comment;
260 494
261 open my $fh, "<", $path 495 open my $fh, "<:raw:perlio:utf8", $path
262 or Carp::croak "$path: $!"; 496 or Carp::croak "$path: $!";
263 497
264 binmode $fh; 498# binmode $fh;
265 499
266 my $parse_block; $parse_block = sub { 500 my $parse_block; $parse_block = sub {
267 my %arc = @_; 501 my %arc = @_;
268 502
269 while (<$fh>) { 503 while (<$fh>) {
270 s/\s+$//; 504 s/\s+$//;
271 if (/^end$/i) { 505 if (/^end$/i) {
272 last; 506 last;
507
273 } elsif (/^arch (\S+)$/i) { 508 } elsif (/^arch (\S+)$/i) {
274 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1); 509 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
510
275 } elsif (/^lore$/i) { 511 } elsif (/^lore$/i) {
276 while (<$fh>) { 512 while (<$fh>) {
277 last if /^endlore\s*$/i; 513 last if /^endlore\s*$/i;
278 $arc{lore} .= $_; 514 $arc{lore} .= $_;
279 } 515 }
280 } elsif (/^msg$/i) { 516 } elsif (/^msg$/i) {
281 while (<$fh>) { 517 while (<$fh>) {
282 last if /^endmsg\s*$/i; 518 last if /^endmsg\s*$/i;
283 $arc{msg} .= $_; 519 $arc{msg} .= $_;
284 } 520 }
521 } elsif (/^anim$/i) {
522 while (<$fh>) {
523 last if /^mina\s*$/i;
524 chomp;
525 push @{ $arc{anim} }, $_;
526 }
285 } elsif (/^(\S+)\s*(.*)$/) { 527 } elsif (/^(\S+)\s*(.*)$/) {
286 $arc{lc $1} = $2; 528 $arc{lc $1} = $2;
287 } elsif (/^\s*($|#)/) { 529 } elsif (/^\s*#/) {
530 $arc{_comment} .= "$_\n";
531
532 } elsif (/^\s*$/) {
288 # 533 #
289 } else { 534 } else {
290 warn "$path: unparsable line '$_' in arch $arc{_name}"; 535 warn "$path: unparsable line '$_' in arch $arc{_name}";
291 } 536 }
292 } 537 }
… …
298 s/\s+$//; 543 s/\s+$//;
299 if (/^more$/i) { 544 if (/^more$/i) {
300 $more = $prev; 545 $more = $prev;
301 } elsif (/^object (\S+)$/i) { 546 } elsif (/^object (\S+)$/i) {
302 my $name = $1; 547 my $name = $1;
303 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';
304 552
305 if ($more) { 553 if ($more) {
306 $more->{more} = $arc; 554 $more->{more} = $arc;
307 } else { 555 } else {
308 $arc{$name} = $arc; 556 $arc{$name} = $arc;
309 } 557 }
310 $prev = $arc; 558 $prev = $arc;
311 $more = undef; 559 $more = undef;
312 } elsif (/^arch (\S+)$/i) { 560 } elsif (/^arch (\S+)$/i) {
313 my $name = $1; 561 my $name = $1;
314 my $arc = normalize_object $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';
315 566
316 if ($more) { 567 if ($more) {
317 $more->{more} = $arc; 568 $more->{more} = $arc;
318 } else { 569 } else {
319 push @{ $arc{arch} }, $arc; 570 push @{ $arc{arch} }, $arc;
320 } 571 }
321 $prev = $arc; 572 $prev = $arc;
322 $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";
323 } elsif (/^\s*($|#)/) { 585 } elsif (/^\s*($|#)/) {
324 # 586 #
325 } else { 587 } else {
326 warn "$path: unparseable top-level line '$_'"; 588 die "$path: unparseable top-level line '$_'";
327 } 589 }
328 } 590 }
329 591
330 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.
331 593
332 \%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
333} 677}
334 678
335# 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
336# NOTE: the arrays in the hash values are references to 680# NOTE: the arrays in the hash values are references to
337# the archs from $ARCH 681# the archs from $ARCH
338sub editor_archs { 682sub editor_archs {
339 my %paths; 683 my %paths;
340 684
341 for (keys %ARCH) { 685 for (keys %ARCH) {
342 my $arch = $ARCH{$_}; 686 my $arch = $ARCH{$_};
343 push @{$paths{$arch->{editor_folder}}}, \$arch; 687 push @{$paths{$arch->{editor_folder}}}, $arch;
344 } 688 }
345 689
346 \%paths 690 \%paths
347} 691}
348 692
… …
358 my ($a) = @_; 702 my ($a) = @_;
359 703
360 my $o = $ARCH{$a->{_name}} 704 my $o = $ARCH{$a->{_name}}
361 or return; 705 or return;
362 706
363 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"}
364 or (warn "no face data found for arch '$a->{_name}'"), return; 710 or (warn "no face data found for arch '$a->{_name}'"), return;
711 }
365 712
366 if ($face->{w} > 1 || $face->{h} > 1) { 713 if ($face->{w} > 1 || $face->{h} > 1) {
367 # bigface 714 # bigface
368 return (0, 0, $face->{w} - 1, $face->{h} - 1); 715 return (0, 0, $face->{w} - 1, $face->{h} - 1);
369 716
… …
413 my $type = $obj->{type} || $arch->{type}; 760 my $type = $obj->{type} || $arch->{type};
414 761
415 if ($type > 0) { 762 if ($type > 0) {
416 $root = $Crossfire::Data::ATTR{$type}; 763 $root = $Crossfire::Data::ATTR{$type};
417 } 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 {
418 $root = $Crossfire::Data::TYPE{Misc}; 776 $root = $Crossfire::Data::TYPE{Misc};
419
420 type:
421 for (@Crossfire::Data::ATTR0) {
422 my $req = $_->{required}
423 or die "internal error: ATTR0 without 'required'";
424
425 keys %$req;
426 while (my ($k, $v) = each %$req) {
427 next type
428 unless $obj->{$k} == $v || $arch->{$k} == $v;
429 }
430
431 $root = $_;
432 } 777 }
433 } 778 }
434 779
435 my @import = ($root); 780 my @import = ($root);
436 781
… …
478 ]; 823 ];
479 824
480 $attr 825 $attr
481} 826}
482 827
483sub arch_edit_sections {
484# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
485# edit_type = 0;
486# else if (edit_type != 0) {
487# // all flags from 'check_type' must be unset in this arch because they get recalculated now
488# edit_type &= ~check_type;
489# }
490#
491# }
492# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
493# getAttributeValue("alive", defarch) == 1 &&
494# (getAttributeValue("monster", defarch) == 1 ||
495# getAttributeValue("generator", defarch) == 1)) {
496# // Monster: monsters/npcs/generators
497# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
498# }
499# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
500# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
501# // Walls
502# edit_type |= IGUIConstants.TILE_EDIT_WALL;
503# }
504# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
505# getAttributeValue("connected", defarch) != 0) {
506# // Connected Objects
507# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
508# }
509# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
510# arch_type == 66 || arch_type == 41 || arch_type == 95) {
511# // Exit: teleporter/exit/trapdoors
512# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
513# }
514# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
515# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
516# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
517# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
518# arch_type == 124 || arch_type == 130)) {
519# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
520# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
521# }
522# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
523# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
524# arch_type == 91 || arch_type == 21 || arch_type == 24) {
525# // Door: door/special door/gates + keys
526# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
527# }
528# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
529# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
530# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
531# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
532# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
533# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
534# arch_type == 122 || arch_type == 3)) {
535# // Equipment: weapons/armour/wands/rods
536# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
537# }
538#
539# return(edit_type);
540#
541#
542}
543
544sub cache_file($$&&) { 828sub cache_file($$&&) {
545 my ($src, $cache, $load, $create) = @_; 829 my ($src, $cache, $load, $create) = @_;
546 830
547 my ($size, $mtime) = (stat $src)[7,9] 831 my ($size, $mtime) = (stat $src)[7,9]
548 or Carp::croak "$src: $!"; 832 or Carp::croak "$src: $!";
… …
610 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 894 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
611 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 895 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
612 or die "$VARDIR/tilecache.png: $!"; 896 or die "$VARDIR/tilecache.png: $!";
613 *FACE = $_[0]; 897 *FACE = $_[0];
614 }, sub { 898 }, sub {
615 require File::Temp;
616
617 my $tile = read_pak "$LIB/crossfire.0"; 899 my $tile = read_pak "$LIB/crossfire.0";
618 900
619 my %cache; 901 my %cache;
620 902
621 my $idx = 0; 903 my $idx = 0;
622 904
623 for my $name (sort keys %$tile) { 905 for my $name (sort keys %$tile) {
624 my ($fh, $filename) = File::Temp::tempfile (); 906 my $pb = new Gtk2::Gdk::PixbufLoader;
625 print $fh $tile->{$name}; 907 $pb->write ($tile->{$name});
626 close $fh; 908 $pb->close;
627 my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename; 909 my $pb = $pb->get_pixbuf;
628 unlink $filename;
629 910
630 my $tile = $cache{$name} = { 911 my $tile = $cache{$name} = {
631 pb => $pb, 912 pb => $pb,
632 idx => $idx, 913 idx => $idx,
633 w => int $pb->get_width / TILESIZE, 914 w => int $pb->get_width / TILESIZE,
… …
651 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64); 932 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
652 } 933 }
653 } 934 }
654 } 935 }
655 936
656 $pb->save ("$VARDIR/tilecache.png", "png"); 937 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
657 938
658 \%cache 939 \%cache
659 }; 940 };
660} 941}
661 942

Diff Legend

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