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

Diff Legend

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