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.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
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 '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}
234
235sub load_ref($) {
236 my ($path) = @_;
237
238 open my $fh, "<:raw:perlio", $path
239 or die "$path: $!";
240 local $/;
241
242 thaw <$fh>
243}
244
245sub save_ref($$) {
246 my ($ref, $path) = @_;
247
248 open my $fh, ">:raw:perlio", "$path~"
249 or die "$path~: $!";
250 print $fh freeze $ref;
251 close $fh;
252 rename "$path~", $path
253 or die "$path: $!";
254}
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
325sub normalize_object($) {
326 my ($ob) = @_;
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
348 delete @$ob{qw(
349 can_knockback can_parry can_impale can_cut can_dam_armour
350 can_apply pass_thru can_pass_thru
351 )};
352
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) {
359 next unless exists $ob->{$attr};
360
361 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
362 }
363
364 # convert outdated movement flags to new movement sets
365 if (defined (my $v = delete $ob->{no_pass})) {
366 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
367 }
368 if (defined (my $v = delete $ob->{slow_move})) {
369 $ob->{move_slow} += "walk";
370 $ob->{move_slow_penalty} = $v;
371 }
372 if (defined (my $v = delete $ob->{walk_on})) {
373 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
374 }
375 if (defined (my $v = delete $ob->{walk_off})) {
376 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
377 }
378 if (defined (my $v = delete $ob->{fly_on})) {
379 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
380 }
381 if (defined (my $v = delete $ob->{fly_off})) {
382 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
383 }
384 if (defined (my $v = delete $ob->{flying})) {
385 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
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};
402
403 $ob
404}
405
406# arch as in "arch xxx", ie.. objects
49sub normalize_arch($) { 407sub normalize_arch($) {
50 my ($ob) = @_; 408 my ($ob) = @_;
51 409
410 normalize_object $ob;
411
52 my $arch = $ARCH{$ob->{_name}} 412 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 413 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 414
57 if ($arch->{type} == 22) { # map 415 if ($arch->{type} == 22) { # map
58 my %normalize = ( 416 my %normalize = (
59 "enter_x" => "hp", 417 "enter_x" => "hp",
60 "enter_y" => "sp", 418 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 428 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 429 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 430 $ob->{$k2} = $v;
73 } 431 }
74 } 432 }
75 } 433 } 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 434 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 435 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 436 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 437 next if $k eq "_name";
105 delete $ob->{$k}; 438 delete $ob->{$k};
106 } 439 }
440 }
441 }
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;
107 } 448 }
108 449
109 $ob 450 $ob
110} 451}
111 452
453sub attr_thaw($) {
454 my ($ob) = @_;
455
456 $ob->{attach} = from_json $ob->{attach}
457 if exists $ob->{attach};
458
459 $ob
460}
461
462sub attr_freeze($) {
463 my ($ob) = @_;
464
465 $ob->{attach} = Crossfire::to_json $ob->{attach}
466 if exists $ob->{attach};
467
468 $ob
469}
470
112sub read_pak($;$) { 471sub read_pak($) {
113 my ($path, $cache) = @_; 472 my ($path) = @_;
114 473
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 474 my %pak;
121 475
122 open my $fh, "<:raw", $path 476 open my $fh, "<:raw:perlio", $path
123 or Carp::croak "$_[0]: $!"; 477 or Carp::croak "$_[0]: $!";
478 binmode $fh;
124 while (<$fh>) { 479 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 480 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 481 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 482 read $fh, $pak{$path}, $len;
128 } 483 }
129 484
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 485 \%pak
134 }
135} 486}
136 487
137sub read_arch($;$) { 488sub read_arch($;$) {
138 my ($path, $cache) = @_; 489 my ($path, $toplevel) = @_;
139 490
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 491 my %arc;
146 my ($more, $prev); 492 my ($more, $prev);
493 my $comment;
147 494
148 open my $fh, "<:raw", $path 495 open my $fh, "<:raw:perlio:utf8", $path
149 or Carp::croak "$path: $!"; 496 or Carp::croak "$path: $!";
150 497
498# binmode $fh;
499
151 my $parse_block; $parse_block = sub { 500 my $parse_block; $parse_block = sub {
152 my %arc = @_; 501 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 502
182 while (<$fh>) { 503 while (<$fh>) {
183 s/\s+$//; 504 s/\s+$//;
184 if (/^more$/i) { 505 if (/^end$/i) {
185 $more = $prev; 506 last;
507
186 } elsif (/^object (\S+)$/i) { 508 } elsif (/^arch (\S+)$/i) {
187 my $name = $1; 509 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name);
189 510
190 if ($more) { 511 } elsif (/^lore$/i) {
191 $more->{more} = $arc; 512 while (<$fh>) {
192 } else { 513 last if /^endlore\s*$/i;
193 $arc{$name} = $arc; 514 $arc{lore} .= $_;
194 } 515 }
195 $prev = $arc; 516 } elsif (/^msg$/i) {
196 $more = undef; 517 while (<$fh>) {
518 last if /^endmsg\s*$/i;
519 $arc{msg} .= $_;
520 }
521 } elsif (/^anim$/i) {
522 while (<$fh>) {
523 last if /^mina\s*$/i;
524 chomp;
525 push @{ $arc{anim} }, $_;
526 }
197 } elsif (/^arch (\S+)$/i) { 527 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 528 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 529 } elsif (/^\s*#/) {
530 $arc{_comment} .= "$_\n";
531
532 } elsif (/^\s*$/) {
200 # 533 #
201 } else { 534 } else {
202 warn "$path: unparseable top-level line '$_'"; 535 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 }
204 } 536 }
205 537 }
206 undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208 Storable::nstore \%arc, $cache
209 if defined $cache;
210 538
211 \%arc 539 \%arc
212 } 540 };
541
542 while (<$fh>) {
543 s/\s+$//;
544 if (/^more$/i) {
545 $more = $prev;
546 } elsif (/^object (\S+)$/i) {
547 my $name = $1;
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';
552
553 if ($more) {
554 $more->{more} = $arc;
555 } else {
556 $arc{$name} = $arc;
557 }
558 $prev = $arc;
559 $more = undef;
560 } elsif (/^arch (\S+)$/i) {
561 my $name = $1;
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';
566
567 if ($more) {
568 $more->{more} = $arc;
569 } else {
570 push @{ $arc{arch} }, $arc;
571 }
572 $prev = $arc;
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";
585 } elsif (/^\s*($|#)/) {
586 #
587 } else {
588 die "$path: unparseable top-level line '$_'";
589 }
590 }
591
592 undef $parse_block; # work around bug in perl not freeing $fh etc.
593
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
213} 677}
214 678
215# 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
216# NOTE: the arrays in the hash values are references to 680# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 681# the archs from $ARCH
218sub editor_archs { 682sub editor_archs {
219 my %paths; 683 my %paths;
220 684
221 for (keys %ARCH) { 685 for (keys %ARCH) {
222 my $arch = $ARCH{$_}; 686 my $arch = $ARCH{$_};
223 push @{$paths{$arch->{editor_folder}}}, \$arch; 687 push @{$paths{$arch->{editor_folder}}}, $arch;
224 } 688 }
225 689
226 \%paths 690 \%paths
227} 691}
228 692
… …
238 my ($a) = @_; 702 my ($a) = @_;
239 703
240 my $o = $ARCH{$a->{_name}} 704 my $o = $ARCH{$a->{_name}}
241 or return; 705 or return;
242 706
243 my $face = $FACE{$a->{face} || $o->{face}} 707 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
708 unless ($face) {
709 $face = $FACE{"blank.x11"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 710 or (warn "no face data found for arch '$a->{_name}'"), return;
711 }
245 712
246 if ($face->{w} > 1 || $face->{h} > 1) { 713 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 714 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 715 return (0, 0, $face->{w} - 1, $face->{h} - 1);
249 716
… …
264 # single face 731 # single face
265 return (0, 0, 0, 0); 732 return (0, 0, 0, 0);
266 } 733 }
267} 734}
268 735
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 736=item $type = arch_attr $arch
278 737
279Returns a hashref describing the object and its attributes. It can contain 738Returns a hashref describing the object and its attributes. It can contain
280the following keys: 739the following keys:
281 740
282 name the name, suitable for display purposes 741 name the name, suitable for display purposes
283 ignore 742 ignore
284 attr 743 attr
285 desc 744 desc
286 use 745 use
287 section => [name => \%attr, name => \%attr] 746 section => [name => \%attr, name => \%attr]
747 import
288 748
289=cut 749=cut
290 750
291sub arch_attr($) { 751sub arch_attr($) {
292 my ($arch) = @_; 752 my ($obj) = @_;
293 753
294 require Crossfire::Data; 754 require Crossfire::Data;
295 755
756 my $root;
296 my $attr; 757 my $attr = { };
758
759 my $arch = $ARCH{ $obj->{_name} };
760 my $type = $obj->{type} || $arch->{type};
297 761
298 if ($arch->{type} > 0) { 762 if ($type > 0) {
299 $attr = $Crossfire::Data::ATTR{$arch->{type}+0}; 763 $root = $Crossfire::Data::ATTR{$type};
300 } 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 {
301 $attr = $Crossfire::Data::TYPE{Misc}; 776 $root = $Crossfire::Data::TYPE{Misc};
777 }
778 }
302 779
303 type: 780 my @import = ($root);
304 for (@Crossfire::Data::ATTR0) { 781
305 my $req = $_->{required} 782 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
306 or die "internal error: ATTR0 without 'required'"; 783 unless $type == 116;
307 784
308 while (my ($k, $v) = each %$req) { 785 my (%ignore);
309 next type 786 my (@section_order, %section, @attr_order);
310 unless $arch->{$k} == $v; 787
788 while (my $type = shift @import) {
789 push @import, @{$type->{import} || []};
790
791 $attr->{$_} ||= $type->{$_}
792 for qw(name desc use);
793
794 for (@{$type->{ignore} || []}) {
795 $ignore{$_}++ for ref $_ ? @$_ : $_;
796 }
797
798 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
799 my ($name, $attr) = @$_;
800 push @section_order, $name;
801 for (@$attr) {
802 my ($k, $v) = @$_;
803 push @attr_order, $k;
804 $section{$name}{$k} ||= $v;
805 }
806 }
807 }
808
809 $attr->{section} = [
810 map !exists $section{$_} ? () : do {
811 my $attr = delete $section{$_};
812
813 [
814 $_,
815 map exists $attr->{$_} && !$ignore{$_}
816 ? [$_ => delete $attr->{$_}] : (),
817 @attr_order
818 ]
311 } 819 },
312
313 $attr = $_;
314 } 820
821 exists $section{$_} ? [$_ => delete $section{$_}] : (),
822 @section_order
823 ];
824
825 $attr
826}
827
828sub cache_file($$&&) {
829 my ($src, $cache, $load, $create) = @_;
830
831 my ($size, $mtime) = (stat $src)[7,9]
832 or Carp::croak "$src: $!";
833
834 if (-e $cache) {
835 my $ref = eval { load_ref $cache };
836
837 if ($ref->{version} == 1
838 && $ref->{size} == $size
839 && $ref->{mtime} == $mtime
840 && eval { $load->($ref->{data}); 1 }) {
841 return;
842 }
843 }
844
845 my $ref = {
846 version => 1,
847 size => $size,
848 mtime => $mtime,
849 data => $create->(),
315 } 850 };
316 851
317 use PApp::Util; 852 $load->($ref->{data});
318 warn PApp::Util::dumpval $attr;
319}
320 853
321sub arch_edit_sections { 854 save_ref $ref, $cache;
322# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 855}
323# edit_type = 0; 856
324# else if (edit_type != 0) { 857=item set_libdir $path
325# // all flags from 'check_type' must be unset in this arch because they get recalculated now 858
326# edit_type &= ~check_type; 859Sets the library directory to the given path
860(default: $ENV{CROSSFIRE_LIBDIR}).
861
862You have to (re-)load the archetypes and tilecache manually after steting
863the library path.
864
865=cut
866
867sub set_libdir($) {
868 $LIB = $_[0];
869}
870
871=item load_archetypes
872
873(Re-)Load archetypes into %ARCH.
874
875=cut
876
877sub load_archetypes() {
878 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
879 *ARCH = $_[0];
880 }, sub {
881 read_arch "$LIB/archetypes"
882 };
883}
884
885=item load_tilecache
886
887(Re-)Load %TILE and %FACE.
888
889=cut
890
891sub load_tilecache() {
892 require Gtk2;
893
894 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
895 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
896 or die "$VARDIR/tilecache.png: $!";
897 *FACE = $_[0];
898 }, sub {
899 my $tile = read_pak "$LIB/crossfire.0";
900
901 my %cache;
902
903 my $idx = 0;
904
905 for my $name (sort keys %$tile) {
906 my $pb = new Gtk2::Gdk::PixbufLoader;
907 $pb->write ($tile->{$name});
908 $pb->close;
909 my $pb = $pb->get_pixbuf;
910
911 my $tile = $cache{$name} = {
912 pb => $pb,
913 idx => $idx,
914 w => int $pb->get_width / TILESIZE,
915 h => int $pb->get_height / TILESIZE,
916 };
917
918
919 $idx += $tile->{w} * $tile->{h};
327# } 920 }
328# 921
922 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
923
924 while (my ($name, $tile) = each %cache) {
925 my $tpb = delete $tile->{pb};
926 my $ofs = $tile->{idx};
927
928 for my $x (0 .. $tile->{w} - 1) {
929 for my $y (0 .. $tile->{h} - 1) {
930 my $idx = $ofs + $x + $y * $tile->{w};
931 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
932 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
933 }
934 }
329# } 935 }
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 936
382$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 937 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
383 938
384init $CACHEDIR; 939 \%cache
940 };
941}
385 942
386=head1 AUTHOR 943=head1 AUTHOR
387 944
388 Marc Lehmann <schmorp@schmorp.de> 945 Marc Lehmann <schmorp@schmorp.de>
389 http://home.schmorp.de/ 946 http://home.schmorp.de/

Diff Legend

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