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.18 by root, Wed Feb 22 22:41:22 2006 UTC vs.
Revision 1.94 by root, Sat Mar 3 20:07:04 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
15use Carp (); 15use Carp ();
16use Storable; 16use File::Spec;
17use List::Util qw(min max); 17use List::Util qw(min max);
18use Storable qw(freeze thaw);
18 19
19#XXX: The map_* procedures scream for a map-object
20
21our @EXPORT = 20our @EXPORT = qw(
22 qw(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);
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 or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; 37
38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
40 : File::Spec->tmpdir . "/crossfire";
41
42mkdir $VARDIR, 0777;
26 43
27sub TILESIZE (){ 32 } 44sub TILESIZE (){ 32 }
28 45
29our $CACHEDIR;
30our %ARCH; 46our %ARCH;
31our %FACE; 47our %FACE;
32our $TILE; 48our $TILE;
33 49
34our %FIELD_MULTILINE = ( 50our %FIELD_MULTILINE = (
35 msg => "endmsg", 51 msg => "endmsg",
36 lore => "endlore", 52 lore => "endlore",
53 maplore => "endmaplore",
37); 54);
38 55
39# not used yet, maybe alphabetical is ok 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
60# same as in server save routine, to (hopefully) be compatible
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
40our @FIELD_ORDER = (qw(name name_pl)); 72our @FIELD_ORDER = (qw(
73 elevation
41 74
75 name name_pl custom_name attach title race
76 slaying skill msg lore other_arch face
77 #todo-events
78 animation is_animated
79 str dex con wis pow cha int
80 hp maxhp sp maxsp grace maxgrace
81 exp perm_exp expmul
82 food dam luck wc ac x y speed speed_left move_state attack_movement
83 nrof level direction type subtype attacktype
84
85 resist_physical resist_magic resist_fire resist_electricity
86 resist_cold resist_confusion resist_acid resist_drain
87 resist_weaponmagic resist_ghosthit resist_poison resist_slow
88 resist_paralyze resist_turn_undead resist_fear resist_cancellation
89 resist_deplete resist_death resist_chaos resist_counterspell
90 resist_godpower resist_holyword resist_blind resist_internal
91 resist_life_stealing resist_disease
92
93 path_attuned path_repelled path_denied material materialname
94 value carrying weight invisible state magic
95 last_heal last_sp last_grace last_eat
96 connected glow_radius randomitems npx_status npc_program
97 run_away pick_up container will_apply smoothlevel
98 current_weapon_script weapontype tooltype elevation client_type
99 item_power duration range
100 range_modifier duration_modifier dam_modifier gen_sp_armour
101 move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
102
103 alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
104 friendly generator is_thrown auto_apply treasure player sold see_invisible
105 can_roll overlay_floor is_turnable is_used_up identified reflecting changing
106 splitting hitback startequip blocksview undead scared unaggressive
107 reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
108 run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
109 can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
110 has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
111 random_move only_attack confused stealth cursed damned see_anywhere
112 known_magical known_cursed can_use_skill been_applied has_ready_scroll
113 can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
114 has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
115 is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
116 activate_on_push activate_on_release is_water use_content_on_gen is_buildable
117
118 body_range body_arm body_torso body_head body_neck body_skill
119 body_finger body_shoulder body_foot body_hand body_wrist body_waist
120));
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
42sub MOVE_WALK (){ 0x1 } 137sub MOVE_WALK (){ 0x01 }
43sub MOVE_FLY_LOW (){ 0x2 } 138sub MOVE_FLY_LOW (){ 0x02 }
44sub MOVE_FLY_HIGH (){ 0x4 } 139sub MOVE_FLY_HIGH (){ 0x04 }
45sub MOVE_FLYING (){ 0x6 } 140sub MOVE_FLYING (){ 0x06 }
46sub MOVE_SWIM (){ 0x8 } 141sub MOVE_SWIM (){ 0x08 }
47sub MOVE_ALL (){ 0xf } 142sub MOVE_BOAT (){ 0x10 }
143sub MOVE_KNOWN (){ 0x1f } # all of above
144sub MOVE_ALL (){ 0x10000 } # very special value
48 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 '=' => sub { bless [@{$_[0]}], ref $_[0] },
163 '""' => \&as_string,
164 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
165 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
166 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
168 'x=' => sub {
169 my $cur = $_[0] >= $_[1];
170 if (!defined $cur) {
171 if ($_[0] >= "all") {
172 $_[0] -= $_[1];
173 } else {
174 $_[0] += $_[1];
175 }
176 } elsif ($cur) {
177 $_[0] -= $_[1];
178 } else {
179 $_[0] /= $_[1];
180 }
181
182 $_[0]
183 },
184 'eq' => sub { "$_[0]" eq "$_[1]" },
185 'ne' => sub { "$_[0]" ne "$_[1]" },
186 ;
187}
188
189sub Crossfire::MoveType::new {
190 my ($class, $string) = @_;
191
192 my $mask;
193 my $value;
194
195 if ($string =~ /^\s*\d+\s*$/) {
196 $mask = MOVE_ALL;
197 $value = $string+0;
198 } else {
199 for (split /\s+/, lc $string) {
200 if (s/^-//) {
201 $mask |= $MOVE_TYPE{$_};
202 $value &= ~$MOVE_TYPE{$_};
203 } else {
204 $mask |= $MOVE_TYPE{$_};
205 $value |= $MOVE_TYPE{$_};
206 }
207 }
208 }
209
210 (bless [$mask, $value], $class)->normalise
211}
212
213sub Crossfire::MoveType::normalise {
214 my ($self) = @_;
215
216 if ($self->[0] & MOVE_ALL) {
217 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
218 $self->[0] &= $mask;
219 $self->[1] &= $mask;
220 }
221
222 $self->[1] &= $self->[0];
223
224 $self
225}
226
227sub Crossfire::MoveType::as_string {
228 my ($self) = @_;
229
230 my @res;
231
232 my ($mask, $value) = @$self;
233
234 for (@Crossfire::MOVE_TYPE) {
235 my $bit = $Crossfire::MOVE_TYPE{$_};
236 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
237 $mask &= ~$bit;
238 push @res, $value & $bit ? $_ : "-$_";
239 }
240 }
241
242 join " ", @res
243}
244
245sub load_ref($) {
246 my ($path) = @_;
247
248 open my $fh, "<:raw:perlio", $path
249 or die "$path: $!";
250 local $/;
251
252 thaw <$fh>
253}
254
255sub save_ref($$) {
256 my ($ref, $path) = @_;
257
258 open my $fh, ">:raw:perlio", "$path~"
259 or die "$path~: $!";
260 print $fh freeze $ref;
261 close $fh;
262 rename "$path~", $path
263 or die "$path: $!";
264}
265
266my %attack_mask = (
267 physical => 0x00000001,
268 magic => 0x00000002,
269 fire => 0x00000004,
270 electricity => 0x00000008,
271 cold => 0x00000010,
272 confusion => 0x00000020,
273 acid => 0x00000040,
274 drain => 0x00000080,
275 weaponmagic => 0x00000100,
276 ghosthit => 0x00000200,
277 poison => 0x00000400,
278 slow => 0x00000800,
279 paralyze => 0x00001000,
280 turn_undead => 0x00002000,
281 fear => 0x00004000,
282 cancellation => 0x00008000,
283 deplete => 0x00010000,
284 death => 0x00020000,
285 chaos => 0x00040000,
286 counterspell => 0x00080000,
287 godpower => 0x00100000,
288 holyword => 0x00200000,
289 blind => 0x00400000,
290 internal => 0x00800000,
291 life_stealing => 0x01000000,
292 disease => 0x02000000,
293);
294
295sub _add_resist($$$) {
296 my ($ob, $mask, $value) = @_;
297
298 while (my ($k, $v) = each %attack_mask) {
299 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
300 }
301}
302
303my %MATERIAL = reverse
304 paper => 1,
305 iron => 2,
306 glass => 4,
307 leather => 8,
308 wood => 16,
309 organic => 32,
310 stone => 64,
311 cloth => 128,
312 adamant => 256,
313 liquid => 512,
314 tin => 1024,
315 bone => 2048,
316 ice => 4096,
317
318 # guesses
319 runestone => 12,
320 bronze => 18,
321 "ancient wood" => 20,
322 glass => 36,
323 marble => 66,
324 ice => 68,
325 stone => 70,
326 stone => 80,
327 cloth => 136,
328 ironwood => 144,
329 adamantium => 258,
330 glacium => 260,
331 blood => 544,
332;
333
334# object as in "Object xxx", i.e. archetypes
335sub normalize_object($) {
336 my ($ob) = @_;
337
338 # convert material bitset to materialname, if possible
339 if (exists $ob->{material}) {
340 if (!$ob->{material}) {
341 delete $ob->{material};
342 } elsif (exists $ob->{materialname}) {
343 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
344 delete $ob->{material};
345 } else {
346 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
347 delete $ob->{material}; # assume materilname is more specific and nuke material
348 }
349 } elsif (my $name = $MATERIAL{$ob->{material}}) {
350 delete $ob->{material};
351 $ob->{materialname} = $name;
352 } else {
353 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
354 }
355 }
356
357 # nuke outdated or never supported fields
358 delete @$ob{qw(
359 can_knockback can_parry can_impale can_cut can_dam_armour
360 can_apply pass_thru can_pass_thru
361 )};
362
363 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
364 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
365 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
366
367 # convert movement strings to bitsets
368 for my $attr (keys %FIELD_MOVEMENT) {
369 next unless exists $ob->{$attr};
370
371 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
372 }
373
374 # convert outdated movement flags to new movement sets
375 if (defined (my $v = delete $ob->{no_pass})) {
376 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
377 }
378 if (defined (my $v = delete $ob->{slow_move})) {
379 $ob->{move_slow} += "walk";
380 $ob->{move_slow_penalty} = $v;
381 }
382 if (defined (my $v = delete $ob->{walk_on})) {
383 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
384 }
385 if (defined (my $v = delete $ob->{walk_off})) {
386 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
387 }
388 if (defined (my $v = delete $ob->{fly_on})) {
389 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
390 }
391 if (defined (my $v = delete $ob->{fly_off})) {
392 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
393 }
394 if (defined (my $v = delete $ob->{flying})) {
395 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
396 }
397
398 # convert idiotic event_xxx things into objects
399 while (my ($event, $subtype) = each %EVENT_TYPE) {
400 if (exists $ob->{"event_${event}_plugin"}) {
401 push @{$ob->{inventory}}, {
402 _name => "event_$event",
403 title => delete $ob->{"event_${event}_plugin"},
404 slaying => delete $ob->{"event_${event}"},
405 name => delete $ob->{"event_${event}_options"},
406 };
407 }
408 }
409
410 # some archetypes had "+3" instead of the canonical "3", so fix
411 $ob->{dam} *= 1 if exists $ob->{dam};
412
413 $ob
414}
415
416# arch as in "arch xxx", ie.. objects
49sub normalize_arch($) { 417sub normalize_arch($) {
50 my ($ob) = @_; 418 my ($ob) = @_;
51 419
420 normalize_object $ob;
421
52 my $arch = $ARCH{$ob->{_name}} 422 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 423 or (warn "$ob->{_name}: no such archetype", return $ob);
54
55 delete $ob->{$_} for qw(can_knockback can_parry can_impale can_cut can_dam_armour can_apply);
56 424
57 if ($arch->{type} == 22) { # map 425 if ($arch->{type} == 22) { # map
58 my %normalize = ( 426 my %normalize = (
59 "enter_x" => "hp", 427 "enter_x" => "hp",
60 "enter_y" => "sp", 428 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 438 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 439 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 440 $ob->{$k2} = $v;
73 } 441 }
74 } 442 }
75 } 443 } else {
76
77 if (defined (my $v = delete $ob->{no_pass})) {
78 $ob->{move_block} = $v ? MOVE_ALL : 0;
79 }
80 if (defined (my $v = delete $ob->{walk_on})) {
81 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
82 : $ob->{move_on} & ~MOVE_WALK;
83 }
84 if (defined (my $v = delete $ob->{walk_off})) {
85 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
86 : $ob->{move_off} & ~MOVE_WALK;
87 }
88 if (defined (my $v = delete $ob->{fly_on})) {
89 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
90 : $ob->{move_on} & ~MOVE_FLY_LOW;
91 }
92 if (defined (my $v = delete $ob->{fly_off})) {
93 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
94 : $ob->{move_off} & ~MOVE_FLY_LOW;
95 }
96 if (defined (my $v = delete $ob->{flying})) {
97 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
98 : $ob->{move_type} & ~MOVE_FLY_LOW;
99 }
100
101 # if value matches archetype default, delete 444 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 445 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 446 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 447 next if $k eq "_name";
105 delete $ob->{$k}; 448 delete $ob->{$k};
106 } 449 }
450 }
451 }
452
453 # a speciality for the editor
454 if (exists $ob->{attack_movement}) {
455 my $am = delete $ob->{attack_movement};
456 $ob->{attack_movement_bits_0_3} = $am & 15;
457 $ob->{attack_movement_bits_4_7} = $am & 240;
107 } 458 }
108 459
109 $ob 460 $ob
110} 461}
111 462
463sub attr_thaw($) {
464 my ($ob) = @_;
465
466 $ob->{attach} = from_json $ob->{attach}
467 if exists $ob->{attach};
468
469 $ob
470}
471
472sub attr_freeze($) {
473 my ($ob) = @_;
474
475 $ob->{attach} = Crossfire::to_json $ob->{attach}
476 if exists $ob->{attach};
477
478 $ob
479}
480
112sub read_pak($;$) { 481sub read_pak($) {
113 my ($path, $cache) = @_; 482 my ($path) = @_;
114 483
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 484 my %pak;
121 485
122 open my $fh, "<:raw", $path 486 open my $fh, "<:raw:perlio", $path
123 or Carp::croak "$_[0]: $!"; 487 or Carp::croak "$_[0]: $!";
488 binmode $fh;
124 while (<$fh>) { 489 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 490 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 491 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 492 read $fh, $pak{$path}, $len;
128 } 493 }
129 494
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 495 \%pak
134 }
135} 496}
136 497
137sub read_arch($;$) { 498sub read_arch($;$) {
138 my ($path, $cache) = @_; 499 my ($path, $toplevel) = @_;
139 500
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 501 my %arc;
146 my ($more, $prev); 502 my ($more, $prev);
503 my $comment;
147 504
148 open my $fh, "<:raw", $path 505 open my $fh, "<:raw:perlio:utf8", $path
149 or Carp::croak "$path: $!"; 506 or Carp::croak "$path: $!";
150 507
508# binmode $fh;
509
151 my $parse_block; $parse_block = sub { 510 my $parse_block; $parse_block = sub {
152 my %arc = @_; 511 my %arc = @_;
153
154 while (<$fh>) {
155 s/\s+$//;
156 if (/^end$/i) {
157 last;
158 } elsif (/^arch (\S+)$/) {
159 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
160 } elsif (/^lore$/) {
161 while (<$fh>) {
162 last if /^endlore\s*$/i;
163 $arc{lore} .= $_;
164 }
165 } elsif (/^msg$/) {
166 while (<$fh>) {
167 last if /^endmsg\s*$/i;
168 $arc{msg} .= $_;
169 }
170 } elsif (/^(\S+)\s*(.*)$/) {
171 $arc{lc $1} = $2;
172 } elsif (/^\s*($|#)/) {
173 #
174 } else {
175 warn "$path: unparsable line '$_' in arch $arc{_name}";
176 }
177 }
178
179 \%arc
180 };
181 512
182 while (<$fh>) { 513 while (<$fh>) {
183 s/\s+$//; 514 s/\s+$//;
184 if (/^more$/i) { 515 if (/^end$/i) {
185 $more = $prev; 516 last;
517
186 } elsif (/^object (\S+)$/i) { 518 } elsif (/^arch (\S+)$/i) {
187 my $name = $1; 519 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name);
189 520
190 if ($more) { 521 } elsif (/^lore$/i) {
191 $more->{more} = $arc; 522 while (<$fh>) {
192 } else { 523 last if /^endlore\s*$/i;
193 $arc{$name} = $arc; 524 $arc{lore} .= $_;
194 } 525 }
195 $prev = $arc; 526 } elsif (/^msg$/i) {
196 $more = undef; 527 while (<$fh>) {
528 last if /^endmsg\s*$/i;
529 $arc{msg} .= $_;
530 }
531 } elsif (/^anim$/i) {
532 while (<$fh>) {
533 last if /^mina\s*$/i;
534 chomp;
535 push @{ $arc{anim} }, $_;
536 }
197 } elsif (/^arch (\S+)$/i) { 537 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 538 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 539 } elsif (/^\s*#/) {
540 $arc{_comment} .= "$_\n";
541
542 } elsif (/^\s*$/) {
200 # 543 #
201 } else { 544 } else {
202 warn "$path: unparseable top-level line '$_'"; 545 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 }
204 } 546 }
205 547 }
206 undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208 Storable::nstore \%arc, $cache
209 if defined $cache;
210 548
211 \%arc 549 \%arc
212 } 550 };
551
552 while (<$fh>) {
553 s/\s+$//;
554 if (/^more$/i) {
555 $more = $prev;
556 } elsif (/^object (\S+)$/i) {
557 my $name = $1;
558 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
559 undef $comment;
560 delete $arc{_comment} unless length $arc{_comment};
561 $arc->{_atype} = 'object';
562
563 if ($more) {
564 $more->{more} = $arc;
565 } else {
566 $arc{$name} = $arc;
567 }
568 $prev = $arc;
569 $more = undef;
570 } elsif (/^arch (\S+)$/i) {
571 my $name = $1;
572 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
573 undef $comment;
574 delete $arc{_comment} unless length $arc{_comment};
575 $arc->{_atype} = 'arch';
576
577 if ($more) {
578 $more->{more} = $arc;
579 } else {
580 push @{ $arc{arch} }, $arc;
581 }
582 $prev = $arc;
583 $more = undef;
584 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
585 if ($1 eq "lev_array") {
586 while (<$fh>) {
587 last if /^endplst\s*$/;
588 push @{$toplevel->{lev_array}}, $_+0;
589 }
590 } else {
591 $toplevel->{$1} = $2;
592 }
593 } elsif (/^\s*#/) {
594 $comment .= "$_\n";
595 } elsif (/^\s*($|#)/) {
596 #
597 } else {
598 die "$path: unparseable top-level line '$_'";
599 }
600 }
601
602 undef $parse_block; # work around bug in perl not freeing $fh etc.
603
604 \%arc
605}
606
607sub archlist_to_string {
608 my ($arch) = @_;
609
610 my $str;
611
612 my $append; $append = sub {
613 my %a = %{$_[0]};
614
615 Crossfire::attr_freeze \%a;
616 Crossfire::normalize_arch \%a;
617
618 # undo the bit-split we did before
619 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
620 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
621 | (delete $a{attack_movement_bits_4_7});
622 }
623
624 if (my $comment = delete $a{_comment}) {
625 if ($comment =~ /[^\n\s#]/) {
626 $str .= $comment;
627 }
628 }
629
630 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
631
632 my $inv = delete $a{inventory};
633 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
634 my $anim = delete $a{anim};
635
636 if ($a{_atype} eq 'object') {
637 $str .= join "\n", "anim", @$anim, "mina\n"
638 if $anim;
639 }
640
641 my @kv;
642
643 for ($a{_name} eq "map"
644 ? @Crossfire::FIELD_ORDER_MAP
645 : @Crossfire::FIELD_ORDER) {
646 push @kv, [$_, delete $a{$_}]
647 if exists $a{$_};
648 }
649
650 for (sort keys %a) {
651 next if /^_/; # ignore our _-keys
652 push @kv, [$_, delete $a{$_}];
653 }
654
655 for (@kv) {
656 my ($k, $v) = @$_;
657
658 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
659 $v =~ s/\n$//;
660 $str .= "$k\n$v\n$end\n";
661 } else {
662 $str .= "$k $v\n";
663 }
664 }
665
666 if ($inv) {
667 $append->($_) for @$inv;
668 }
669
670 $str .= "end\n";
671
672 if ($a{_atype} eq 'object') {
673 if ($more) {
674 $str .= "more\n";
675 $append->($more) if $more;
676 } else {
677 $str .= "\n";
678 }
679 }
680 };
681
682 for (@$arch) {
683 $append->($_);
684 }
685
686 $str
213} 687}
214 688
215# put all archs into a hash with editor_face as it's key 689# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 690# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 691# the archs from $ARCH
218sub editor_archs { 692sub editor_archs {
219 my %paths; 693 my %paths;
220 694
221 for (keys %ARCH) { 695 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 696 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 697 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 698 }
225 699
226 \%paths 700 \%paths
227} 701}
228 702
… …
238 my ($a) = @_; 712 my ($a) = @_;
239 713
240 my $o = $ARCH{$a->{_name}} 714 my $o = $ARCH{$a->{_name}}
241 or return; 715 or return;
242 716
243 my $face = $FACE{$a->{face} || $o->{face}} 717 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
718 unless ($face) {
719 $face = $FACE{"blank.x11"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 720 or (warn "no face data found for arch '$a->{_name}'"), return;
721 }
245 722
246 if ($face->{w} > 1 || $face->{h} > 1) { 723 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 724 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 725 return (0, 0, $face->{w} - 1, $face->{h} - 1);
249 726
… …
264 # single face 741 # single face
265 return (0, 0, 0, 0); 742 return (0, 0, 0, 0);
266 } 743 }
267} 744}
268 745
269sub init($) {
270 my ($cachedir) = @_;
271
272 return if %ARCH;
273
274 *ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
275}
276
277=item $data = arch_attr $arch 746=item $type = arch_attr $arch
278 747
279Returns a hashref describing the object and its attributes. It can contain 748Returns a hashref describing the object and its attributes. It can contain
280the following keys: 749the following keys:
281 750
282 name the name, suitable for display purposes 751 name the name, suitable for display purposes
283 ignore 752 ignore
284 attr 753 attr
285 desc 754 desc
286 use 755 use
287 section => [name => \%attr, name => \%attr] 756 section => [name => \%attr, name => \%attr]
757 import
288 758
289=cut 759=cut
290 760
291sub arch_attr($) { 761sub arch_attr($) {
292 my ($arch) = @_; 762 my ($obj) = @_;
293 763
294 require Crossfire::Data; 764 require Crossfire::Data;
295 765
766 my $root;
296 my $attr; 767 my $attr = { };
768
769 my $arch = $ARCH{ $obj->{_name} };
770 my $type = $obj->{type} || $arch->{type};
297 771
298 if ($arch->{type} > 0) { 772 if ($type > 0) {
299 $attr = $Crossfire::Data::ATTR{$arch->{type}+0}; 773 $root = $Crossfire::Data::ATTR{$type};
300 } else { 774 } else {
775 my %a = (%$arch, %$obj);
776
777 if ($a{is_floor} && !$a{alive}) {
778 $root = $Crossfire::Data::TYPE{Floor};
779 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
780 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
781 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
782 $root = $Crossfire::Data::TYPE{Wall};
783 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
784 $root = $Crossfire::Data::TYPE{"Weak Wall"};
785 } else {
301 $attr = $Crossfire::Data::TYPE{Misc}; 786 $root = $Crossfire::Data::TYPE{Misc};
787 }
788 }
302 789
303 type: 790 my @import = ($root);
304 for (@Crossfire::Data::ATTR0) { 791
305 my $req = $_->{required} 792 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
306 or die "internal error: ATTR0 without 'required'"; 793 unless $type == 116;
307 794
308 while (my ($k, $v) = each %$req) { 795 my (%ignore);
309 next type 796 my (@section_order, %section, @attr_order);
310 unless $arch->{$k} == $v; 797
798 while (my $type = shift @import) {
799 push @import, @{$type->{import} || []};
800
801 $attr->{$_} ||= $type->{$_}
802 for qw(name desc use);
803
804 for (@{$type->{ignore} || []}) {
805 $ignore{$_}++ for ref $_ ? @$_ : $_;
806 }
807
808 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
809 my ($name, $attr) = @$_;
810 push @section_order, $name;
811 for (@$attr) {
812 my ($k, $v) = @$_;
813 push @attr_order, $k;
814 $section{$name}{$k} ||= $v;
815 }
816 }
817 }
818
819 $attr->{section} = [
820 map !exists $section{$_} ? () : do {
821 my $attr = delete $section{$_};
822
823 [
824 $_,
825 map exists $attr->{$_} && !$ignore{$_}
826 ? [$_ => delete $attr->{$_}] : (),
827 @attr_order
828 ]
311 } 829 },
312
313 $attr = $_;
314 } 830
831 exists $section{$_} ? [$_ => delete $section{$_}] : (),
832 @section_order
833 ];
834
835 $attr
836}
837
838sub cache_file($$&&) {
839 my ($src, $cache, $load, $create) = @_;
840
841 my ($size, $mtime) = (stat $src)[7,9]
842 or Carp::croak "$src: $!";
843
844 if (-e $cache) {
845 my $ref = eval { load_ref $cache };
846
847 if ($ref->{version} == 1
848 && $ref->{size} == $size
849 && $ref->{mtime} == $mtime
850 && eval { $load->($ref->{data}); 1 }) {
851 return;
852 }
853 }
854
855 my $ref = {
856 version => 1,
857 size => $size,
858 mtime => $mtime,
859 data => $create->(),
315 } 860 };
316 861
317 use PApp::Util; 862 $load->($ref->{data});
318 warn PApp::Util::dumpval $attr;
319}
320 863
321sub arch_edit_sections { 864 save_ref $ref, $cache;
322# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 865}
323# edit_type = 0; 866
324# else if (edit_type != 0) { 867=item set_libdir $path
325# // all flags from 'check_type' must be unset in this arch because they get recalculated now 868
326# edit_type &= ~check_type; 869Sets the library directory to the given path
870(default: $ENV{CROSSFIRE_LIBDIR}).
871
872You have to (re-)load the archetypes and tilecache manually after steting
873the library path.
874
875=cut
876
877sub set_libdir($) {
878 $LIB = $_[0];
879}
880
881=item load_archetypes
882
883(Re-)Load archetypes into %ARCH.
884
885=cut
886
887sub load_archetypes() {
888 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
889 *ARCH = $_[0];
890 }, sub {
891 read_arch "$LIB/archetypes"
892 };
893}
894
895=item load_tilecache
896
897(Re-)Load %TILE and %FACE.
898
899=cut
900
901sub load_tilecache() {
902 require Gtk2;
903
904 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
905 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
906 or die "$VARDIR/tilecache.png: $!";
907 *FACE = $_[0];
908 }, sub {
909 my $tile = read_pak "$LIB/crossfire.0";
910
911 my %cache;
912
913 my $idx = 0;
914
915 for my $name (sort keys %$tile) {
916 my $pb = new Gtk2::Gdk::PixbufLoader;
917 $pb->write ($tile->{$name});
918 $pb->close;
919 my $pb = $pb->get_pixbuf;
920
921 my $tile = $cache{$name} = {
922 pb => $pb,
923 idx => $idx,
924 w => int $pb->get_width / TILESIZE,
925 h => int $pb->get_height / TILESIZE,
926 };
927
928
929 $idx += $tile->{w} * $tile->{h};
327# } 930 }
328# 931
932 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
933
934 while (my ($name, $tile) = each %cache) {
935 my $tpb = delete $tile->{pb};
936 my $ofs = $tile->{idx};
937
938 for my $x (0 .. $tile->{w} - 1) {
939 for my $y (0 .. $tile->{h} - 1) {
940 my $idx = $ofs + $x + $y * $tile->{w};
941 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
942 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
943 }
944 }
329# } 945 }
330# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
331# getAttributeValue("alive", defarch) == 1 &&
332# (getAttributeValue("monster", defarch) == 1 ||
333# getAttributeValue("generator", defarch) == 1)) {
334# // Monster: monsters/npcs/generators
335# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
336# }
337# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
338# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
339# // Walls
340# edit_type |= IGUIConstants.TILE_EDIT_WALL;
341# }
342# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
343# getAttributeValue("connected", defarch) != 0) {
344# // Connected Objects
345# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
346# }
347# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
348# arch_type == 66 || arch_type == 41 || arch_type == 95) {
349# // Exit: teleporter/exit/trapdoors
350# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
351# }
352# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
353# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
354# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
355# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
356# arch_type == 124 || arch_type == 130)) {
357# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
358# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
359# }
360# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
361# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
362# arch_type == 91 || arch_type == 21 || arch_type == 24) {
363# // Door: door/special door/gates + keys
364# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
365# }
366# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
367# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
368# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
369# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
370# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
371# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
372# arch_type == 122 || arch_type == 3)) {
373# // Equipment: weapons/armour/wands/rods
374# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
375# }
376#
377# return(edit_type);
378#
379#
380}
381 946
382$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 947 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
383 948
384init $CACHEDIR; 949 \%cache
950 };
951}
385 952
386=head1 AUTHOR 953=head1 AUTHOR
387 954
388 Marc Lehmann <schmorp@schmorp.de> 955 Marc Lehmann <schmorp@schmorp.de>
389 http://home.schmorp.de/ 956 http://home.schmorp.de/

Diff Legend

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