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.17 by root, Wed Feb 22 22:36:45 2006 UTC vs.
Revision 1.90 by root, Sat Mar 3 18:58:25 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 '""' => \&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 ;
180}
181
182sub Crossfire::MoveType::new {
183 my ($class, $string) = @_;
184
185 my $mask;
186 my $value;
187
188 for (split /\s+/, lc $string) {
189 if (s/^-//) {
190 $mask |= $MOVE_TYPE{$_};
191 $value &= ~$MOVE_TYPE{$_};
192 } else {
193 $mask |= $MOVE_TYPE{$_};
194 $value |= $MOVE_TYPE{$_};
195 }
196 }
197
198 (bless [$mask, $value], $class)->normalise
199}
200
201sub Crossfire::MoveType::normalise {
202 my ($self) = @_;
203
204 if ($self->[0] & MOVE_ALL) {
205 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
206 $self->[0] &= $mask;
207 $self->[1] &= $mask;
208 }
209
210 $self->[1] &= $self->[0];
211
212 $self
213}
214
215sub Crossfire::MoveType::as_string {
216 my ($self) = @_;
217
218 my @res;
219
220 my ($mask, $value) = @$self;
221
222 for (@Crossfire::MOVE_TYPE) {
223 my $bit = $Crossfire::MOVE_TYPE{$_};
224 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
225 $mask &= ~$bit;
226 push @res, $value & $bit ? $_ : "-$_";
227 }
228 }
229
230 join " ", @res
231}
232
233sub load_ref($) {
234 my ($path) = @_;
235
236 open my $fh, "<:raw:perlio", $path
237 or die "$path: $!";
238 local $/;
239
240 thaw <$fh>
241}
242
243sub save_ref($$) {
244 my ($ref, $path) = @_;
245
246 open my $fh, ">:raw:perlio", "$path~"
247 or die "$path~: $!";
248 print $fh freeze $ref;
249 close $fh;
250 rename "$path~", $path
251 or die "$path: $!";
252}
253
254my %attack_mask = (
255 physical => 0x00000001,
256 magic => 0x00000002,
257 fire => 0x00000004,
258 electricity => 0x00000008,
259 cold => 0x00000010,
260 confusion => 0x00000020,
261 acid => 0x00000040,
262 drain => 0x00000080,
263 weaponmagic => 0x00000100,
264 ghosthit => 0x00000200,
265 poison => 0x00000400,
266 slow => 0x00000800,
267 paralyze => 0x00001000,
268 turn_undead => 0x00002000,
269 fear => 0x00004000,
270 cancellation => 0x00008000,
271 deplete => 0x00010000,
272 death => 0x00020000,
273 chaos => 0x00040000,
274 counterspell => 0x00080000,
275 godpower => 0x00100000,
276 holyword => 0x00200000,
277 blind => 0x00400000,
278 internal => 0x00800000,
279 life_stealing => 0x01000000,
280 disease => 0x02000000,
281);
282
283sub _add_resist($$$) {
284 my ($ob, $mask, $value) = @_;
285
286 while (my ($k, $v) = each %attack_mask) {
287 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
288 }
289}
290
291my %MATERIAL = reverse
292 paper => 1,
293 iron => 2,
294 glass => 4,
295 leather => 8,
296 wood => 16,
297 organic => 32,
298 stone => 64,
299 cloth => 128,
300 adamant => 256,
301 liquid => 512,
302 tin => 1024,
303 bone => 2048,
304 ice => 4096,
305
306 # guesses
307 runestone => 12,
308 bronze => 18,
309 "ancient wood" => 20,
310 glass => 36,
311 marble => 66,
312 ice => 68,
313 stone => 70,
314 stone => 80,
315 cloth => 136,
316 ironwood => 144,
317 adamantium => 258,
318 glacium => 260,
319 blood => 544,
320;
321
322# object as in "Object xxx", i.e. archetypes
323sub normalize_object($) {
324 my ($ob) = @_;
325
326 # convert material bitset to materialname, if possible
327 if (exists $ob->{material}) {
328 if (!$ob->{material}) {
329 delete $ob->{material};
330 } elsif (exists $ob->{materialname}) {
331 if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
332 delete $ob->{material};
333 } else {
334 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
335 delete $ob->{material}; # assume materilname is more specific and nuke material
336 }
337 } elsif (my $name = $MATERIAL{$ob->{material}}) {
338 delete $ob->{material};
339 $ob->{materialname} = $name;
340 } else {
341 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
342 }
343 }
344
345 # nuke outdated or never supported fields
346 delete @$ob{qw(
347 can_knockback can_parry can_impale can_cut can_dam_armour
348 can_apply pass_thru can_pass_thru
349 )};
350
351 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
352 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
353 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
354
355 # convert movement strings to bitsets
356 for my $attr (keys %FIELD_MOVEMENT) {
357 next unless exists $ob->{$attr};
358
359 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
360 }
361
362 # convert outdated movement flags to new movement sets
363 if (defined (my $v = delete $ob->{no_pass})) {
364 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
365 }
366 if (defined (my $v = delete $ob->{slow_move})) {
367 $ob->{move_slow} += "walk";
368 $ob->{move_slow_penalty} = $v;
369 }
370 if (defined (my $v = delete $ob->{walk_on})) {
371 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
372 }
373 if (defined (my $v = delete $ob->{walk_off})) {
374 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
375 }
376 if (defined (my $v = delete $ob->{fly_on})) {
377 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
378 }
379 if (defined (my $v = delete $ob->{fly_off})) {
380 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
381 }
382 if (defined (my $v = delete $ob->{flying})) {
383 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
384 }
385
386 # convert idiotic event_xxx things into objects
387 while (my ($event, $subtype) = each %EVENT_TYPE) {
388 if (exists $ob->{"event_${event}_plugin"}) {
389 push @{$ob->{inventory}}, {
390 _name => "event_$event",
391 title => delete $ob->{"event_${event}_plugin"},
392 slaying => delete $ob->{"event_${event}"},
393 name => delete $ob->{"event_${event}_options"},
394 };
395 }
396 }
397
398 # some archetypes had "+3" instead of the canonical "3", so fix
399 $ob->{dam} *= 1 if exists $ob->{dam};
400
401 $ob
402}
403
404# arch as in "arch xxx", ie.. objects
49sub normalize_arch($) { 405sub normalize_arch($) {
50 my ($ob) = @_; 406 my ($ob) = @_;
51 407
408 normalize_object $ob;
409
52 my $arch = $ARCH{$ob->{_name}} 410 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 411 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 412
57 if ($arch->{type} == 22) { # map 413 if ($arch->{type} == 22) { # map
58 my %normalize = ( 414 my %normalize = (
59 "enter_x" => "hp", 415 "enter_x" => "hp",
60 "enter_y" => "sp", 416 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 426 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 427 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 428 $ob->{$k2} = $v;
73 } 429 }
74 } 430 }
75 } 431 } 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 432 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 433 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 434 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 435 next if $k eq "_name";
105 delete $ob->{$k}; 436 delete $ob->{$k};
106 } 437 }
438 }
439 }
440
441 # a speciality for the editor
442 if (exists $ob->{attack_movement}) {
443 my $am = delete $ob->{attack_movement};
444 $ob->{attack_movement_bits_0_3} = $am & 15;
445 $ob->{attack_movement_bits_4_7} = $am & 240;
107 } 446 }
108 447
109 $ob 448 $ob
110} 449}
111 450
451sub attr_thaw($) {
452 my ($ob) = @_;
453
454 $ob->{attach} = from_json $ob->{attach}
455 if exists $ob->{attach};
456
457 $ob
458}
459
460sub attr_freeze($) {
461 my ($ob) = @_;
462
463 $ob->{attach} = Crossfire::to_json $ob->{attach}
464 if exists $ob->{attach};
465
466 $ob
467}
468
112sub read_pak($;$) { 469sub read_pak($) {
113 my ($path, $cache) = @_; 470 my ($path) = @_;
114 471
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 472 my %pak;
121 473
122 open my $fh, "<:raw", $path 474 open my $fh, "<:raw:perlio", $path
123 or Carp::croak "$_[0]: $!"; 475 or Carp::croak "$_[0]: $!";
476 binmode $fh;
124 while (<$fh>) { 477 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 478 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 479 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 480 read $fh, $pak{$path}, $len;
128 } 481 }
129 482
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 483 \%pak
134 }
135} 484}
136 485
137sub read_arch($;$) { 486sub read_arch($;$) {
138 my ($path, $cache) = @_; 487 my ($path, $toplevel) = @_;
139 488
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 489 my %arc;
146 my ($more, $prev); 490 my ($more, $prev);
491 my $comment;
147 492
148 open my $fh, "<:raw", $path 493 open my $fh, "<:raw:perlio:utf8", $path
149 or Carp::croak "$path: $!"; 494 or Carp::croak "$path: $!";
150 495
496# binmode $fh;
497
151 my $parse_block; $parse_block = sub { 498 my $parse_block; $parse_block = sub {
152 my %arc = @_; 499 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 500
182 while (<$fh>) { 501 while (<$fh>) {
183 s/\s+$//; 502 s/\s+$//;
184 if (/^more$/i) { 503 if (/^end$/i) {
185 $more = $prev; 504 last;
505
186 } elsif (/^object (\S+)$/i) { 506 } elsif (/^arch (\S+)$/i) {
187 my $name = $1; 507 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name);
189 508
190 if ($more) { 509 } elsif (/^lore$/i) {
191 $more->{more} = $arc; 510 while (<$fh>) {
192 } else { 511 last if /^endlore\s*$/i;
193 $arc{$name} = $arc; 512 $arc{lore} .= $_;
194 } 513 }
195 $prev = $arc; 514 } elsif (/^msg$/i) {
196 $more = undef; 515 while (<$fh>) {
516 last if /^endmsg\s*$/i;
517 $arc{msg} .= $_;
518 }
519 } elsif (/^anim$/i) {
520 while (<$fh>) {
521 last if /^mina\s*$/i;
522 chomp;
523 push @{ $arc{anim} }, $_;
524 }
197 } elsif (/^arch (\S+)$/i) { 525 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 526 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 527 } elsif (/^\s*#/) {
528 $arc{_comment} .= "$_\n";
529
530 } elsif (/^\s*$/) {
200 # 531 #
201 } else { 532 } else {
202 warn "$path: unparseable top-level line '$_'"; 533 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 }
204 } 534 }
205 535 }
206 undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208 Storable::nstore \%arc, $cache
209 if defined $cache;
210 536
211 \%arc 537 \%arc
212 } 538 };
539
540 while (<$fh>) {
541 s/\s+$//;
542 if (/^more$/i) {
543 $more = $prev;
544 } elsif (/^object (\S+)$/i) {
545 my $name = $1;
546 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
547 undef $comment;
548 delete $arc{_comment} unless length $arc{_comment};
549 $arc->{_atype} = 'object';
550
551 if ($more) {
552 $more->{more} = $arc;
553 } else {
554 $arc{$name} = $arc;
555 }
556 $prev = $arc;
557 $more = undef;
558 } elsif (/^arch (\S+)$/i) {
559 my $name = $1;
560 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
561 undef $comment;
562 delete $arc{_comment} unless length $arc{_comment};
563 $arc->{_atype} = 'arch';
564
565 if ($more) {
566 $more->{more} = $arc;
567 } else {
568 push @{ $arc{arch} }, $arc;
569 }
570 $prev = $arc;
571 $more = undef;
572 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
573 if ($1 eq "lev_array") {
574 while (<$fh>) {
575 last if /^endplst\s*$/;
576 push @{$toplevel->{lev_array}}, $_+0;
577 }
578 } else {
579 $toplevel->{$1} = $2;
580 }
581 } elsif (/^\s*#/) {
582 $comment .= "$_\n";
583 } elsif (/^\s*($|#)/) {
584 #
585 } else {
586 die "$path: unparseable top-level line '$_'";
587 }
588 }
589
590 undef $parse_block; # work around bug in perl not freeing $fh etc.
591
592 \%arc
593}
594
595sub archlist_to_string {
596 my ($arch) = @_;
597
598 my $str;
599
600 my $append; $append = sub {
601 my %a = %{$_[0]};
602
603 Crossfire::attr_freeze \%a;
604 Crossfire::normalize_arch \%a;
605
606 # undo the bit-split we did before
607 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
608 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
609 | (delete $a{attack_movement_bits_4_7});
610 }
611
612 if (my $comment = delete $a{_comment}) {
613 if ($comment =~ /[^\n\s#]/) {
614 $str .= $comment;
615 }
616 }
617
618 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
619
620 my $inv = delete $a{inventory};
621 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
622 my $anim = delete $a{anim};
623
624 if ($a{_atype} eq 'object') {
625 $str .= join "\n", "anim", @$anim, "mina\n"
626 if $anim;
627 }
628
629 my @kv;
630
631 for ($a{_name} eq "map"
632 ? @Crossfire::FIELD_ORDER_MAP
633 : @Crossfire::FIELD_ORDER) {
634 push @kv, [$_, delete $a{$_}]
635 if exists $a{$_};
636 }
637
638 for (sort keys %a) {
639 next if /^_/; # ignore our _-keys
640 push @kv, [$_, delete $a{$_}];
641 }
642
643 for (@kv) {
644 my ($k, $v) = @$_;
645
646 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
647 $v =~ s/\n$//;
648 $str .= "$k\n$v\n$end\n";
649 } else {
650 $str .= "$k $v\n";
651 }
652 }
653
654 if ($inv) {
655 $append->($_) for @$inv;
656 }
657
658 $str .= "end\n";
659
660 if ($a{_atype} eq 'object') {
661 if ($more) {
662 $str .= "more\n";
663 $append->($more) if $more;
664 } else {
665 $str .= "\n";
666 }
667 }
668 };
669
670 for (@$arch) {
671 $append->($_);
672 }
673
674 $str
213} 675}
214 676
215# put all archs into a hash with editor_face as it's key 677# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 678# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 679# the archs from $ARCH
218sub editor_archs { 680sub editor_archs {
219 my %paths; 681 my %paths;
220 682
221 for (keys %ARCH) { 683 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 684 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 685 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 686 }
225 687
226 \%paths 688 \%paths
227} 689}
228 690
… …
238 my ($a) = @_; 700 my ($a) = @_;
239 701
240 my $o = $ARCH{$a->{_name}} 702 my $o = $ARCH{$a->{_name}}
241 or return; 703 or return;
242 704
243 my $face = $FACE{$a->{face} || $o->{face}} 705 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
706 unless ($face) {
707 $face = $FACE{"blank.x11"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 708 or (warn "no face data found for arch '$a->{_name}'"), return;
709 }
245 710
246 if ($face->{w} > 1 || $face->{h} > 1) { 711 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 712 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 713 return (0, 0, $face->{w} - 1, $face->{h} - 1);
249 714
… …
264 # single face 729 # single face
265 return (0, 0, 0, 0); 730 return (0, 0, 0, 0);
266 } 731 }
267} 732}
268 733
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 734=item $type = arch_attr $arch
278 735
279Returns a hashref describing the object and its attributes. It can contain 736Returns a hashref describing the object and its attributes. It can contain
280the following keys: 737the following keys:
281 738
282 name the name, suitable for display purposes 739 name the name, suitable for display purposes
283 ignore 740 ignore
284 attr 741 attr
285 desc 742 desc
286 use 743 use
287 section => [name => \%attr, name => \%attr] 744 section => [name => \%attr, name => \%attr]
745 import
288 746
289=cut 747=cut
290 748
291sub arch_attr($) { 749sub arch_attr($) {
292 my ($arch) = @_; 750 my ($obj) = @_;
293 751
294 require Crossfire::Data; 752 require Crossfire::Data;
295 753
296 my %attr; 754 my $root;
755 my $attr = { };
756
757 my $arch = $ARCH{ $obj->{_name} };
758 my $type = $obj->{type} || $arch->{type};
297 759
298 if ($arch->{type} > 0) { 760 if ($type > 0) {
299 %attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} || {} }; 761 $root = $Crossfire::Data::ATTR{$type};
300 } else { 762 } else {
301 die; 763 my %a = (%$arch, %$obj);
764
765 if ($a{is_floor} && !$a{alive}) {
766 $root = $Crossfire::Data::TYPE{Floor};
767 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
768 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
769 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
770 $root = $Crossfire::Data::TYPE{Wall};
771 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
772 $root = $Crossfire::Data::TYPE{"Weak Wall"};
773 } else {
774 $root = $Crossfire::Data::TYPE{Misc};
775 }
776 }
777
778 my @import = ($root);
779
780 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
781 unless $type == 116;
782
783 my (%ignore);
784 my (@section_order, %section, @attr_order);
785
786 while (my $type = shift @import) {
787 push @import, @{$type->{import} || []};
788
789 $attr->{$_} ||= $type->{$_}
790 for qw(name desc use);
791
792 for (@{$type->{ignore} || []}) {
793 $ignore{$_}++ for ref $_ ? @$_ : $_;
794 }
795
796 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
797 my ($name, $attr) = @$_;
798 push @section_order, $name;
799 for (@$attr) {
800 my ($k, $v) = @$_;
801 push @attr_order, $k;
802 $section{$name}{$k} ||= $v;
803 }
804 }
805 }
806
807 $attr->{section} = [
808 map !exists $section{$_} ? () : do {
809 my $attr = delete $section{$_};
810
811 [
812 $_,
813 map exists $attr->{$_} && !$ignore{$_}
814 ? [$_ => delete $attr->{$_}] : (),
815 @attr_order
816 ]
817 },
818
819 exists $section{$_} ? [$_ => delete $section{$_}] : (),
820 @section_order
821 ];
822
823 $attr
824}
825
826sub cache_file($$&&) {
827 my ($src, $cache, $load, $create) = @_;
828
829 my ($size, $mtime) = (stat $src)[7,9]
830 or Carp::croak "$src: $!";
831
832 if (-e $cache) {
833 my $ref = eval { load_ref $cache };
834
835 if ($ref->{version} == 1
836 && $ref->{size} == $size
837 && $ref->{mtime} == $mtime
838 && eval { $load->($ref->{data}); 1 }) {
839 return;
840 }
841 }
842
843 my $ref = {
844 version => 1,
845 size => $size,
846 mtime => $mtime,
847 data => $create->(),
302 } 848 };
303 849
304 use PApp::Util; 850 $load->($ref->{data});
305 warn PApp::Util::dumpval \%attr;
306}
307 851
308sub arch_edit_sections { 852 save_ref $ref, $cache;
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 853}
310# edit_type = 0; 854
311# else if (edit_type != 0) { 855=item set_libdir $path
312# // all flags from 'check_type' must be unset in this arch because they get recalculated now 856
313# edit_type &= ~check_type; 857Sets the library directory to the given path
858(default: $ENV{CROSSFIRE_LIBDIR}).
859
860You have to (re-)load the archetypes and tilecache manually after steting
861the library path.
862
863=cut
864
865sub set_libdir($) {
866 $LIB = $_[0];
867}
868
869=item load_archetypes
870
871(Re-)Load archetypes into %ARCH.
872
873=cut
874
875sub load_archetypes() {
876 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
877 *ARCH = $_[0];
878 }, sub {
879 read_arch "$LIB/archetypes"
880 };
881}
882
883=item load_tilecache
884
885(Re-)Load %TILE and %FACE.
886
887=cut
888
889sub load_tilecache() {
890 require Gtk2;
891
892 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
893 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
894 or die "$VARDIR/tilecache.png: $!";
895 *FACE = $_[0];
896 }, sub {
897 my $tile = read_pak "$LIB/crossfire.0";
898
899 my %cache;
900
901 my $idx = 0;
902
903 for my $name (sort keys %$tile) {
904 my $pb = new Gtk2::Gdk::PixbufLoader;
905 $pb->write ($tile->{$name});
906 $pb->close;
907 my $pb = $pb->get_pixbuf;
908
909 my $tile = $cache{$name} = {
910 pb => $pb,
911 idx => $idx,
912 w => int $pb->get_width / TILESIZE,
913 h => int $pb->get_height / TILESIZE,
914 };
915
916
917 $idx += $tile->{w} * $tile->{h};
314# } 918 }
315# 919
920 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
921
922 while (my ($name, $tile) = each %cache) {
923 my $tpb = delete $tile->{pb};
924 my $ofs = $tile->{idx};
925
926 for my $x (0 .. $tile->{w} - 1) {
927 for my $y (0 .. $tile->{h} - 1) {
928 my $idx = $ofs + $x + $y * $tile->{w};
929 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
930 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
931 }
932 }
316# } 933 }
317# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
318# getAttributeValue("alive", defarch) == 1 &&
319# (getAttributeValue("monster", defarch) == 1 ||
320# getAttributeValue("generator", defarch) == 1)) {
321# // Monster: monsters/npcs/generators
322# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
323# }
324# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
325# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
326# // Walls
327# edit_type |= IGUIConstants.TILE_EDIT_WALL;
328# }
329# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
330# getAttributeValue("connected", defarch) != 0) {
331# // Connected Objects
332# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
333# }
334# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
335# arch_type == 66 || arch_type == 41 || arch_type == 95) {
336# // Exit: teleporter/exit/trapdoors
337# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
338# }
339# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
340# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
341# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
342# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
343# arch_type == 124 || arch_type == 130)) {
344# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
345# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
346# }
347# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
348# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
349# arch_type == 91 || arch_type == 21 || arch_type == 24) {
350# // Door: door/special door/gates + keys
351# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
352# }
353# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
354# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
355# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
356# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
357# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
358# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
359# arch_type == 122 || arch_type == 3)) {
360# // Equipment: weapons/armour/wands/rods
361# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
362# }
363#
364# return(edit_type);
365#
366#
367}
368 934
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 935 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
370 936
371init $CACHEDIR; 937 \%cache
938 };
939}
372 940
373=head1 AUTHOR 941=head1 AUTHOR
374 942
375 Marc Lehmann <schmorp@schmorp.de> 943 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 944 http://home.schmorp.de/

Diff Legend

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