ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra/Deliantra.pm
Revision: 1.94
Committed: Sat Mar 3 20:07:04 2007 UTC (17 years, 2 months ago) by root
Branch: MAIN
Changes since 1.93: +5 -1 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 elmex 1.1 =head1 NAME
2    
3     Crossfire - Crossfire maphandling
4    
5     =cut
6    
7 root 1.4 package Crossfire;
8    
9 root 1.78 our $VERSION = '0.96';
10 elmex 1.1
11     use strict;
12    
13 root 1.7 use base 'Exporter';
14    
15 root 1.13 use Carp ();
16 root 1.21 use File::Spec;
17 root 1.15 use List::Util qw(min max);
18 root 1.53 use Storable qw(freeze thaw);
19 elmex 1.1
20 root 1.50 our @EXPORT = qw(
21     read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents
22     );
23    
24 root 1.70 use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working
25    
26     sub from_json($) {
27     $JSON::Syck::ImplicitUnicode = 1;
28     JSON::Syck::Load $_[0]
29     }
30    
31     sub to_json($) {
32     $JSON::Syck::ImplicitUnicode = 0;
33     JSON::Syck::Dump $_[0]
34     }
35    
36 root 1.50 our $LIB = $ENV{CROSSFIRE_LIBDIR};
37 root 1.7
38 root 1.75 our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39     : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
40     : File::Spec->tmpdir . "/crossfire";
41 root 1.50
42     mkdir $VARDIR, 0777;
43 elmex 1.1
44 root 1.7 sub TILESIZE (){ 32 }
45 elmex 1.1
46 root 1.15 our %ARCH;
47     our %FACE;
48     our $TILE;
49 elmex 1.1
50 root 1.13 our %FIELD_MULTILINE = (
51 root 1.50 msg => "endmsg",
52     lore => "endlore",
53     maplore => "endmaplore",
54 root 1.13 );
55    
56 root 1.58 # movement bit type, PITA
57     our %FIELD_MOVEMENT = map +($_ => undef),
58     qw(move_type move_block move_allow move_on move_off move_slow);
59    
60 root 1.54 # same as in server save routine, to (hopefully) be compatible
61     # to the other editors.
62 root 1.56 our @FIELD_ORDER_MAP = (qw(
63 root 1.86 file_format_version
64 root 1.70 name attach swap_time reset_timeout fixed_resettime difficulty region
65 root 1.56 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    
72 root 1.54 our @FIELD_ORDER = (qw(
73 root 1.57 elevation
74    
75 root 1.70 name name_pl custom_name attach title race
76 root 1.54 slaying skill msg lore other_arch face
77 root 1.56 #todo-events
78 root 1.54 animation is_animated
79 root 1.59 str dex con wis pow cha int
80 root 1.54 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 root 1.59 nrof level direction type subtype attacktype
84 root 1.54
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 root 1.13
122 root 1.62 our %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    
137 root 1.50 sub MOVE_WALK (){ 0x01 }
138     sub MOVE_FLY_LOW (){ 0x02 }
139     sub MOVE_FLY_HIGH (){ 0x04 }
140     sub MOVE_FLYING (){ 0x06 }
141     sub MOVE_SWIM (){ 0x08 }
142     sub MOVE_BOAT (){ 0x10 }
143 root 1.58 sub MOVE_KNOWN (){ 0x1f } # all of above
144 root 1.90 sub MOVE_ALL (){ 0x10000 } # very special value
145    
146     our %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    
156     our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat);
157    
158     {
159     package Crossfire::MoveType;
160    
161     use overload
162 root 1.93 '=' => sub { bless [@{$_[0]}], ref $_[0] },
163 root 1.90 '""' => \&as_string,
164     '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
165     '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
166     '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167     '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
168     'x=' => sub {
169     my $cur = $_[0] >= $_[1];
170     if (!defined $cur) {
171 root 1.94 if ($_[0] >= "all") {
172     $_[0] -= $_[1];
173     } else {
174     $_[0] += $_[1];
175     }
176 root 1.90 } elsif ($cur) {
177     $_[0] -= $_[1];
178     } else {
179     $_[0] /= $_[1];
180     }
181    
182     $_[0]
183     },
184 root 1.91 'eq' => sub { "$_[0]" eq "$_[1]" },
185     'ne' => sub { "$_[0]" ne "$_[1]" },
186 root 1.90 ;
187     }
188    
189     sub Crossfire::MoveType::new {
190     my ($class, $string) = @_;
191    
192     my $mask;
193     my $value;
194    
195 root 1.92 if ($string =~ /^\s*\d+\s*$/) {
196     $mask = MOVE_ALL;
197     $value = $string+0;
198     } else {
199     for (split /\s+/, lc $string) {
200     if (s/^-//) {
201     $mask |= $MOVE_TYPE{$_};
202     $value &= ~$MOVE_TYPE{$_};
203     } else {
204     $mask |= $MOVE_TYPE{$_};
205     $value |= $MOVE_TYPE{$_};
206     }
207 root 1.90 }
208     }
209    
210     (bless [$mask, $value], $class)->normalise
211     }
212    
213     sub Crossfire::MoveType::normalise {
214     my ($self) = @_;
215    
216     if ($self->[0] & MOVE_ALL) {
217     my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
218     $self->[0] &= $mask;
219     $self->[1] &= $mask;
220     }
221    
222     $self->[1] &= $self->[0];
223    
224     $self
225     }
226    
227     sub Crossfire::MoveType::as_string {
228     my ($self) = @_;
229    
230     my @res;
231    
232     my ($mask, $value) = @$self;
233    
234     for (@Crossfire::MOVE_TYPE) {
235     my $bit = $Crossfire::MOVE_TYPE{$_};
236     if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
237     $mask &= ~$bit;
238     push @res, $value & $bit ? $_ : "-$_";
239     }
240     }
241    
242     join " ", @res
243     }
244 root 1.14
245 root 1.28 sub load_ref($) {
246     my ($path) = @_;
247    
248 root 1.63 open my $fh, "<:raw:perlio", $path
249 root 1.31 or die "$path: $!";
250 root 1.28 local $/;
251 root 1.33
252 root 1.53 thaw <$fh>
253 root 1.28 }
254    
255     sub save_ref($$) {
256     my ($ref, $path) = @_;
257    
258 root 1.63 open my $fh, ">:raw:perlio", "$path~"
259 root 1.28 or die "$path~: $!";
260 root 1.53 print $fh freeze $ref;
261 root 1.28 close $fh;
262     rename "$path~", $path
263     or die "$path: $!";
264     }
265    
266 root 1.72 my %attack_mask = (
267     physical => 0x00000001,
268     magic => 0x00000002,
269     fire => 0x00000004,
270     electricity => 0x00000008,
271     cold => 0x00000010,
272     confusion => 0x00000020,
273     acid => 0x00000040,
274     drain => 0x00000080,
275     weaponmagic => 0x00000100,
276     ghosthit => 0x00000200,
277     poison => 0x00000400,
278     slow => 0x00000800,
279     paralyze => 0x00001000,
280     turn_undead => 0x00002000,
281     fear => 0x00004000,
282     cancellation => 0x00008000,
283     deplete => 0x00010000,
284     death => 0x00020000,
285     chaos => 0x00040000,
286     counterspell => 0x00080000,
287     godpower => 0x00100000,
288     holyword => 0x00200000,
289     blind => 0x00400000,
290     internal => 0x00800000,
291     life_stealing => 0x01000000,
292     disease => 0x02000000,
293     );
294    
295     sub _add_resist($$$) {
296     my ($ob, $mask, $value) = @_;
297    
298     while (my ($k, $v) = each %attack_mask) {
299 root 1.73 $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v;
300 root 1.72 }
301     }
302    
303 root 1.82 my %MATERIAL = reverse
304     paper => 1,
305     iron => 2,
306     glass => 4,
307     leather => 8,
308     wood => 16,
309     organic => 32,
310     stone => 64,
311     cloth => 128,
312     adamant => 256,
313     liquid => 512,
314     tin => 1024,
315     bone => 2048,
316     ice => 4096,
317 root 1.83
318     # guesses
319     runestone => 12,
320     bronze => 18,
321     "ancient wood" => 20,
322     glass => 36,
323     marble => 66,
324     ice => 68,
325     stone => 70,
326     stone => 80,
327     cloth => 136,
328     ironwood => 144,
329 root 1.85 adamantium => 258,
330 root 1.84 glacium => 260,
331 root 1.83 blood => 544,
332 root 1.82 ;
333    
334 root 1.62 # object as in "Object xxx", i.e. archetypes
335 root 1.52 sub normalize_object($) {
336 root 1.14 my ($ob) = @_;
337    
338 root 1.82 # convert material bitset to materialname, if possible
339     if (exists $ob->{material}) {
340     if (!$ob->{material}) {
341     delete $ob->{material};
342     } elsif (exists $ob->{materialname}) {
343     if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) {
344     delete $ob->{material};
345     } else {
346     warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
347     delete $ob->{material}; # assume materilname is more specific and nuke material
348     }
349 root 1.83 } elsif (my $name = $MATERIAL{$ob->{material}}) {
350     delete $ob->{material};
351     $ob->{materialname} = $name;
352 root 1.82 } else {
353 root 1.83 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
354 root 1.82 }
355     }
356    
357 root 1.62 # nuke outdated or never supported fields
358 root 1.72 delete @$ob{qw(
359 root 1.50 can_knockback can_parry can_impale can_cut can_dam_armour
360     can_apply pass_thru can_pass_thru
361 root 1.72 )};
362    
363     if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
364     if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
365     if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
366 root 1.14
367 root 1.62 # convert movement strings to bitsets
368 root 1.58 for my $attr (keys %FIELD_MOVEMENT) {
369 root 1.50 next unless exists $ob->{$attr};
370 root 1.58
371 root 1.90 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
372 root 1.50 }
373    
374 root 1.62 # convert outdated movement flags to new movement sets
375 root 1.14 if (defined (my $v = delete $ob->{no_pass})) {
376 root 1.90 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
377 root 1.14 }
378 root 1.50 if (defined (my $v = delete $ob->{slow_move})) {
379 root 1.90 $ob->{move_slow} += "walk";
380 root 1.50 $ob->{move_slow_penalty} = $v;
381     }
382 root 1.14 if (defined (my $v = delete $ob->{walk_on})) {
383 root 1.90 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
384 root 1.14 }
385     if (defined (my $v = delete $ob->{walk_off})) {
386 root 1.90 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
387 root 1.14 }
388     if (defined (my $v = delete $ob->{fly_on})) {
389 root 1.90 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
390 root 1.14 }
391     if (defined (my $v = delete $ob->{fly_off})) {
392 root 1.90 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
393 root 1.14 }
394     if (defined (my $v = delete $ob->{flying})) {
395 root 1.90 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
396 root 1.14 }
397    
398 root 1.62 # convert idiotic event_xxx things into objects
399     while (my ($event, $subtype) = each %EVENT_TYPE) {
400     if (exists $ob->{"event_${event}_plugin"}) {
401     push @{$ob->{inventory}}, {
402     _name => "event_$event",
403     title => delete $ob->{"event_${event}_plugin"},
404     slaying => delete $ob->{"event_${event}"},
405     name => delete $ob->{"event_${event}_options"},
406     };
407     }
408     }
409    
410 root 1.73 # some archetypes had "+3" instead of the canonical "3", so fix
411     $ob->{dam} *= 1 if exists $ob->{dam};
412    
413 root 1.52 $ob
414     }
415    
416 root 1.62 # arch as in "arch xxx", ie.. objects
417 root 1.52 sub normalize_arch($) {
418     my ($ob) = @_;
419    
420     normalize_object $ob;
421    
422     my $arch = $ARCH{$ob->{_name}}
423     or (warn "$ob->{_name}: no such archetype", return $ob);
424    
425     if ($arch->{type} == 22) { # map
426     my %normalize = (
427     "enter_x" => "hp",
428     "enter_y" => "sp",
429     "width" => "x",
430     "height" => "y",
431     "reset_timeout" => "weight",
432     "swap_time" => "value",
433     "difficulty" => "level",
434     "darkness" => "invisible",
435     "fixed_resettime" => "stand_still",
436     );
437    
438     while (my ($k2, $k1) = each %normalize) {
439     if (defined (my $v = delete $ob->{$k1})) {
440     $ob->{$k2} = $v;
441     }
442     }
443     } else {
444     # if value matches archetype default, delete
445     while (my ($k, $v) = each %$ob) {
446     if (exists $arch->{$k} and $arch->{$k} eq $v) {
447     next if $k eq "_name";
448     delete $ob->{$k};
449     }
450 root 1.14 }
451     }
452    
453 root 1.57 # a speciality for the editor
454     if (exists $ob->{attack_movement}) {
455     my $am = delete $ob->{attack_movement};
456     $ob->{attack_movement_bits_0_3} = $am & 15;
457     $ob->{attack_movement_bits_4_7} = $am & 240;
458     }
459    
460 root 1.14 $ob
461     }
462 root 1.13
463 root 1.70 sub attr_thaw($) {
464     my ($ob) = @_;
465    
466     $ob->{attach} = from_json $ob->{attach}
467     if exists $ob->{attach};
468    
469     $ob
470     }
471    
472     sub attr_freeze($) {
473     my ($ob) = @_;
474    
475     $ob->{attach} = Crossfire::to_json $ob->{attach}
476     if exists $ob->{attach};
477    
478     $ob
479     }
480    
481 root 1.50 sub read_pak($) {
482     my ($path) = @_;
483    
484     my %pak;
485 elmex 1.1
486 root 1.63 open my $fh, "<:raw:perlio", $path
487 root 1.50 or Carp::croak "$_[0]: $!";
488     binmode $fh;
489     while (<$fh>) {
490     my ($type, $id, $len, $path) = split;
491     $path =~ s/.*\///;
492     read $fh, $pak{$path}, $len;
493 elmex 1.1 }
494 root 1.50
495     \%pak
496 elmex 1.1 }
497    
498 root 1.64 sub read_arch($;$) {
499     my ($path, $toplevel) = @_;
500 root 1.50
501     my %arc;
502     my ($more, $prev);
503 root 1.80 my $comment;
504 root 1.50
505 root 1.63 open my $fh, "<:raw:perlio:utf8", $path
506 root 1.50 or Carp::croak "$path: $!";
507    
508 elmex 1.68 # binmode $fh;
509 elmex 1.1
510 root 1.50 my $parse_block; $parse_block = sub {
511     my %arc = @_;
512 elmex 1.1
513     while (<$fh>) {
514     s/\s+$//;
515 root 1.50 if (/^end$/i) {
516     last;
517 root 1.80
518 root 1.55 } elsif (/^arch (\S+)$/i) {
519 root 1.70 push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1);
520 root 1.80
521 root 1.55 } elsif (/^lore$/i) {
522 root 1.50 while (<$fh>) {
523     last if /^endlore\s*$/i;
524     $arc{lore} .= $_;
525 elmex 1.1 }
526 root 1.55 } elsif (/^msg$/i) {
527 root 1.50 while (<$fh>) {
528     last if /^endmsg\s*$/i;
529     $arc{msg} .= $_;
530     }
531 root 1.65 } elsif (/^anim$/i) {
532     while (<$fh>) {
533     last if /^mina\s*$/i;
534     chomp;
535     push @{ $arc{anim} }, $_;
536     }
537 root 1.50 } elsif (/^(\S+)\s*(.*)$/) {
538     $arc{lc $1} = $2;
539 root 1.80 } elsif (/^\s*#/) {
540 root 1.81 $arc{_comment} .= "$_\n";
541 root 1.80
542     } elsif (/^\s*$/) {
543 elmex 1.1 #
544     } else {
545 root 1.50 warn "$path: unparsable line '$_' in arch $arc{_name}";
546 elmex 1.1 }
547     }
548    
549 root 1.50 \%arc
550     };
551 elmex 1.2
552 root 1.50 while (<$fh>) {
553     s/\s+$//;
554     if (/^more$/i) {
555     $more = $prev;
556     } elsif (/^object (\S+)$/i) {
557     my $name = $1;
558 root 1.80 my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment);
559 root 1.81 undef $comment;
560 root 1.80 delete $arc{_comment} unless length $arc{_comment};
561 elmex 1.71 $arc->{_atype} = 'object';
562 elmex 1.1
563 root 1.50 if ($more) {
564     $more->{more} = $arc;
565     } else {
566     $arc{$name} = $arc;
567     }
568     $prev = $arc;
569     $more = undef;
570     } elsif (/^arch (\S+)$/i) {
571 root 1.55 my $name = $1;
572 root 1.80 my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment);
573 root 1.81 undef $comment;
574 root 1.80 delete $arc{_comment} unless length $arc{_comment};
575 elmex 1.71 $arc->{_atype} = 'arch';
576 root 1.55
577     if ($more) {
578     $more->{more} = $arc;
579     } else {
580     push @{ $arc{arch} }, $arc;
581     }
582     $prev = $arc;
583     $more = undef;
584 root 1.64 } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
585     if ($1 eq "lev_array") {
586     while (<$fh>) {
587     last if /^endplst\s*$/;
588     push @{$toplevel->{lev_array}}, $_+0;
589     }
590     } else {
591     $toplevel->{$1} = $2;
592     }
593 root 1.81 } elsif (/^\s*#/) {
594     $comment .= "$_\n";
595 root 1.50 } elsif (/^\s*($|#)/) {
596     #
597     } else {
598 root 1.64 die "$path: unparseable top-level line '$_'";
599 root 1.50 }
600 elmex 1.2 }
601 root 1.50
602     undef $parse_block; # work around bug in perl not freeing $fh etc.
603    
604     \%arc
605 elmex 1.1 }
606    
607 elmex 1.71 sub archlist_to_string {
608     my ($arch) = @_;
609    
610     my $str;
611    
612     my $append; $append = sub {
613     my %a = %{$_[0]};
614    
615     Crossfire::attr_freeze \%a;
616     Crossfire::normalize_arch \%a;
617    
618     # undo the bit-split we did before
619     if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
620     $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
621     | (delete $a{attack_movement_bits_4_7});
622     }
623    
624 root 1.81 if (my $comment = delete $a{_comment}) {
625     if ($comment =~ /[^\n\s#]/) {
626     $str .= $comment;
627     }
628     }
629    
630 elmex 1.71 $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n";
631    
632 root 1.81 my $inv = delete $a{inventory};
633 elmex 1.71 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
634     my $anim = delete $a{anim};
635    
636 root 1.87 if ($a{_atype} eq 'object') {
637     $str .= join "\n", "anim", @$anim, "mina\n"
638     if $anim;
639     }
640    
641 elmex 1.71 my @kv;
642    
643     for ($a{_name} eq "map"
644     ? @Crossfire::FIELD_ORDER_MAP
645     : @Crossfire::FIELD_ORDER) {
646     push @kv, [$_, delete $a{$_}]
647     if exists $a{$_};
648     }
649    
650     for (sort keys %a) {
651     next if /^_/; # ignore our _-keys
652     push @kv, [$_, delete $a{$_}];
653     }
654    
655     for (@kv) {
656     my ($k, $v) = @$_;
657    
658     if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
659     $v =~ s/\n$//;
660     $str .= "$k\n$v\n$end\n";
661     } else {
662     $str .= "$k $v\n";
663     }
664     }
665    
666     if ($inv) {
667     $append->($_) for @$inv;
668     }
669    
670     $str .= "end\n";
671    
672 root 1.81 if ($a{_atype} eq 'object') {
673     if ($more) {
674     $str .= "more\n";
675     $append->($more) if $more;
676     } else {
677     $str .= "\n";
678     }
679 elmex 1.71 }
680     };
681    
682     for (@$arch) {
683     $append->($_);
684     }
685    
686     $str
687     }
688    
689 elmex 1.10 # put all archs into a hash with editor_face as it's key
690     # NOTE: the arrays in the hash values are references to
691     # the archs from $ARCH
692     sub editor_archs {
693     my %paths;
694    
695 root 1.15 for (keys %ARCH) {
696     my $arch = $ARCH{$_};
697 root 1.62 push @{$paths{$arch->{editor_folder}}}, $arch;
698 elmex 1.10 }
699    
700 root 1.15 \%paths
701 elmex 1.10 }
702    
703 root 1.17 =item ($minx, $miny, $maxx, $maxy) = arch_extents $arch
704    
705     arch_extents determines the extents of the given arch's face(s), linked
706     faces and single faces are handled here it returns (minx, miny, maxx,
707     maxy)
708    
709     =cut
710    
711 root 1.15 sub arch_extents {
712 elmex 1.10 my ($a) = @_;
713    
714 root 1.15 my $o = $ARCH{$a->{_name}}
715     or return;
716 elmex 1.10
717 elmex 1.79 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"};
718     unless ($face) {
719     $face = $FACE{"blank.x11"}
720     or (warn "no face data found for arch '$a->{_name}'"), return;
721     }
722 elmex 1.10
723 root 1.15 if ($face->{w} > 1 || $face->{h} > 1) {
724     # bigface
725     return (0, 0, $face->{w} - 1, $face->{h} - 1);
726    
727     } elsif ($o->{more}) {
728     # linked face
729     my ($minx, $miny, $maxx, $maxy) = ($o->{x}, $o->{y}) x 2;
730    
731     for (; $o; $o = $o->{more}) {
732     $minx = min $minx, $o->{x};
733     $miny = min $miny, $o->{y};
734     $maxx = max $maxx, $o->{x};
735     $maxy = max $maxy, $o->{y};
736     }
737    
738     return ($minx, $miny, $maxx, $maxy);
739 elmex 1.10
740     } else {
741     # single face
742 root 1.15 return (0, 0, 0, 0);
743 elmex 1.10 }
744     }
745    
746 root 1.19 =item $type = arch_attr $arch
747 root 1.17
748     Returns a hashref describing the object and its attributes. It can contain
749     the following keys:
750    
751     name the name, suitable for display purposes
752     ignore
753     attr
754     desc
755     use
756     section => [name => \%attr, name => \%attr]
757 root 1.19 import
758 root 1.17
759     =cut
760    
761     sub arch_attr($) {
762 root 1.46 my ($obj) = @_;
763 root 1.17
764     require Crossfire::Data;
765    
766 root 1.36 my $root;
767 root 1.49 my $attr = { };
768 root 1.46
769     my $arch = $ARCH{ $obj->{_name} };
770     my $type = $obj->{type} || $arch->{type};
771 root 1.17
772 root 1.46 if ($type > 0) {
773     $root = $Crossfire::Data::ATTR{$type};
774 root 1.17 } else {
775 root 1.61 my %a = (%$arch, %$obj);
776 root 1.18
777 root 1.61 if ($a{is_floor} && !$a{alive}) {
778     $root = $Crossfire::Data::TYPE{Floor};
779     } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
780     $root = $Crossfire::Data::TYPE{"Monster & NPC"};
781     } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
782     $root = $Crossfire::Data::TYPE{Wall};
783     } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
784     $root = $Crossfire::Data::TYPE{"Weak Wall"};
785     } else {
786     $root = $Crossfire::Data::TYPE{Misc};
787 root 1.18 }
788 root 1.17 }
789    
790 root 1.47 my @import = ($root);
791    
792     unshift @import, \%Crossfire::Data::DEFAULT_ATTR
793     unless $type == 116;
794    
795 root 1.36 my (%ignore);
796     my (@section_order, %section, @attr_order);
797    
798     while (my $type = shift @import) {
799     push @import, @{$type->{import} || []};
800    
801     $attr->{$_} ||= $type->{$_}
802     for qw(name desc use);
803    
804     for (@{$type->{ignore} || []}) {
805     $ignore{$_}++ for ref $_ ? @$_ : $_;
806     }
807    
808 root 1.43 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
809 root 1.36 my ($name, $attr) = @$_;
810     push @section_order, $name;
811 root 1.43 for (@$attr) {
812 root 1.36 my ($k, $v) = @$_;
813     push @attr_order, $k;
814     $section{$name}{$k} ||= $v;
815     }
816     }
817     }
818    
819     $attr->{section} = [
820     map !exists $section{$_} ? () : do {
821     my $attr = delete $section{$_};
822    
823     [
824     $_,
825 root 1.38 map exists $attr->{$_} && !$ignore{$_}
826     ? [$_ => delete $attr->{$_}] : (),
827 root 1.36 @attr_order
828     ]
829     },
830    
831     exists $section{$_} ? [$_ => delete $section{$_}] : (),
832     @section_order
833     ];
834    
835     $attr
836 root 1.17 }
837    
838 root 1.50 sub cache_file($$&&) {
839     my ($src, $cache, $load, $create) = @_;
840 root 1.24
841 root 1.50 my ($size, $mtime) = (stat $src)[7,9]
842     or Carp::croak "$src: $!";
843    
844     if (-e $cache) {
845     my $ref = eval { load_ref $cache };
846    
847     if ($ref->{version} == 1
848     && $ref->{size} == $size
849     && $ref->{mtime} == $mtime
850     && eval { $load->($ref->{data}); 1 }) {
851     return;
852     }
853     }
854    
855     my $ref = {
856     version => 1,
857     size => $size,
858     mtime => $mtime,
859     data => $create->(),
860     };
861    
862     $load->($ref->{data});
863    
864     save_ref $ref, $cache;
865     }
866    
867     =item set_libdir $path
868    
869     Sets the library directory to the given path
870     (default: $ENV{CROSSFIRE_LIBDIR}).
871    
872     You have to (re-)load the archetypes and tilecache manually after steting
873     the library path.
874    
875     =cut
876    
877     sub set_libdir($) {
878     $LIB = $_[0];
879 root 1.24 }
880    
881 root 1.50 =item load_archetypes
882    
883     (Re-)Load archetypes into %ARCH.
884    
885     =cut
886    
887     sub load_archetypes() {
888     cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
889     *ARCH = $_[0];
890     }, sub {
891     read_arch "$LIB/archetypes"
892     };
893     }
894 root 1.15
895 root 1.50 =item load_tilecache
896    
897     (Re-)Load %TILE and %FACE.
898    
899     =cut
900    
901     sub load_tilecache() {
902     require Gtk2;
903    
904     cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
905     $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
906     or die "$VARDIR/tilecache.png: $!";
907     *FACE = $_[0];
908     }, sub {
909     my $tile = read_pak "$LIB/crossfire.0";
910    
911     my %cache;
912    
913     my $idx = 0;
914    
915     for my $name (sort keys %$tile) {
916 root 1.60 my $pb = new Gtk2::Gdk::PixbufLoader;
917     $pb->write ($tile->{$name});
918     $pb->close;
919     my $pb = $pb->get_pixbuf;
920 root 1.50
921     my $tile = $cache{$name} = {
922     pb => $pb,
923     idx => $idx,
924     w => int $pb->get_width / TILESIZE,
925     h => int $pb->get_height / TILESIZE,
926     };
927    
928    
929     $idx += $tile->{w} * $tile->{h};
930     }
931    
932     my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
933    
934     while (my ($name, $tile) = each %cache) {
935     my $tpb = delete $tile->{pb};
936     my $ofs = $tile->{idx};
937    
938     for my $x (0 .. $tile->{w} - 1) {
939     for my $y (0 .. $tile->{h} - 1) {
940     my $idx = $ofs + $x + $y * $tile->{w};
941     $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
942     $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
943     }
944     }
945     }
946    
947 root 1.60 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
948 root 1.50
949     \%cache
950     };
951     }
952 root 1.15
953 elmex 1.1 =head1 AUTHOR
954    
955     Marc Lehmann <schmorp@schmorp.de>
956     http://home.schmorp.de/
957    
958     Robin Redeker <elmex@ta-sa.org>
959     http://www.ta-sa.org/
960    
961     =cut
962 root 1.4
963     1