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.139 by root, Tue Dec 22 09:52:36 2009 UTC

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

Diff Legend

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