ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra/Deliantra.pm
(Generate patch)

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.17 by root, Wed Feb 22 22:36:45 2006 UTC vs.
Revision 1.61 by root, Mon Mar 27 17:38:18 2006 UTC

… …
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
24our $LIB = $ENV{CROSSFIRE_LIBDIR} 24our $LIB = $ENV{CROSSFIRE_LIBDIR};
25 or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; 25
26our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";
27
28mkdir $VARDIR, 0777;
26 29
27sub TILESIZE (){ 32 } 30sub TILESIZE (){ 32 }
28 31
29our $CACHEDIR;
30our %ARCH; 32our %ARCH;
31our %FACE; 33our %FACE;
32our $TILE; 34our $TILE;
33 35
34our %FIELD_MULTILINE = ( 36our %FIELD_MULTILINE = (
35 msg => "endmsg", 37 msg => "endmsg",
36 lore => "endlore", 38 lore => "endlore",
39 maplore => "endmaplore",
37); 40);
38 41
39# not used yet, maybe alphabetical is ok 42# movement bit type, PITA
43our %FIELD_MOVEMENT = map +($_ => undef),
44 qw(move_type move_block move_allow move_on move_off move_slow);
45
46# same as in server save routine, to (hopefully) be compatible
47# to the other editors.
48our @FIELD_ORDER_MAP = (qw(
49 name swap_time reset_timeout fixed_resettime difficulty region
50 shopitems shopgreed shopmin shopmax shoprace
51 darkness width height enter_x enter_y msg maplore
52 unique template
53 outdoor temp pressure humid windspeed winddir sky nosmooth
54 tile_path_1 tile_path_2 tile_path_3 tile_path_4
55));
56
40our @FIELD_ORDER = (qw(name name_pl)); 57our @FIELD_ORDER = (qw(
58 elevation
41 59
60 name name_pl custom_name title race
61 slaying skill msg lore other_arch face
62 #todo-events
63 animation is_animated
64 str dex con wis pow cha int
65 hp maxhp sp maxsp grace maxgrace
66 exp perm_exp expmul
67 food dam luck wc ac x y speed speed_left move_state attack_movement
68 nrof level direction type subtype attacktype
69
70 resist_physical resist_magic resist_fire resist_electricity
71 resist_cold resist_confusion resist_acid resist_drain
72 resist_weaponmagic resist_ghosthit resist_poison resist_slow
73 resist_paralyze resist_turn_undead resist_fear resist_cancellation
74 resist_deplete resist_death resist_chaos resist_counterspell
75 resist_godpower resist_holyword resist_blind resist_internal
76 resist_life_stealing resist_disease
77
78 path_attuned path_repelled path_denied material materialname
79 value carrying weight invisible state magic
80 last_heal last_sp last_grace last_eat
81 connected glow_radius randomitems npx_status npc_program
82 run_away pick_up container will_apply smoothlevel
83 current_weapon_script weapontype tooltype elevation client_type
84 item_power duration range
85 range_modifier duration_modifier dam_modifier gen_sp_armour
86 move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
87
88 alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
89 friendly generator is_thrown auto_apply treasure player sold see_invisible
90 can_roll overlay_floor is_turnable is_used_up identified reflecting changing
91 splitting hitback startequip blocksview undead scared unaggressive
92 reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
93 run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
94 can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
95 has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
96 random_move only_attack confused stealth cursed damned see_anywhere
97 known_magical known_cursed can_use_skill been_applied has_ready_scroll
98 can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
99 has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
100 is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
101 activate_on_push activate_on_release is_water use_content_on_gen is_buildable
102
103 body_range body_arm body_torso body_head body_neck body_skill
104 body_finger body_shoulder body_foot body_hand body_wrist body_waist
105));
106
42sub MOVE_WALK (){ 0x1 } 107sub MOVE_WALK (){ 0x01 }
43sub MOVE_FLY_LOW (){ 0x2 } 108sub MOVE_FLY_LOW (){ 0x02 }
44sub MOVE_FLY_HIGH (){ 0x4 } 109sub MOVE_FLY_HIGH (){ 0x04 }
45sub MOVE_FLYING (){ 0x6 } 110sub MOVE_FLYING (){ 0x06 }
46sub MOVE_SWIM (){ 0x8 } 111sub MOVE_SWIM (){ 0x08 }
47sub MOVE_ALL (){ 0xf } 112sub MOVE_BOAT (){ 0x10 }
113sub MOVE_KNOWN (){ 0x1f } # all of above
114sub MOVE_ALLBIT (){ 0x10000 }
115sub MOVE_ALL (){ 0x1001f } # very special value, more PITA
116
117sub load_ref($) {
118 my ($path) = @_;
119
120 open my $fh, "<", $path
121 or die "$path: $!";
122 binmode $fh;
123 local $/;
124
125 thaw <$fh>
126}
127
128sub save_ref($$) {
129 my ($ref, $path) = @_;
130
131 open my $fh, ">", "$path~"
132 or die "$path~: $!";
133 binmode $fh;
134 print $fh freeze $ref;
135 close $fh;
136 rename "$path~", $path
137 or die "$path: $!";
138}
139
140sub normalize_object($) {
141 my ($ob) = @_;
142
143 delete $ob->{$_} for qw(
144 can_knockback can_parry can_impale can_cut can_dam_armour
145 can_apply pass_thru can_pass_thru
146 );
147
148 for my $attr (keys %FIELD_MOVEMENT) {
149 next unless exists $ob->{$attr};
150
151 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility
152
153 next if $ob->{$attr} =~ /^\d+$/;
154
155 my $flags = 0;
156
157 # assume list
158 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
159 $flags |= MOVE_WALK if $flag eq "walk";
160 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
161 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
162 $flags |= MOVE_FLYING if $flag eq "flying";
163 $flags |= MOVE_SWIM if $flag eq "swim";
164 $flags |= MOVE_BOAT if $flag eq "boat";
165 $flags |= MOVE_ALL if $flag eq "all";
166
167 $flags &= ~MOVE_WALK if $flag eq "-walk";
168 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
169 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
170 $flags &= ~MOVE_FLYING if $flag eq "-flying";
171 $flags &= ~MOVE_SWIM if $flag eq "-swim";
172 $flags &= ~MOVE_BOAT if $flag eq "-boat";
173 $flags &= ~MOVE_ALL if $flag eq "-all";
174 }
175
176 $ob->{$attr} = $flags;
177 }
178
179 if (defined (my $v = delete $ob->{no_pass})) {
180 $ob->{move_block} = $v ? MOVE_ALL : 0;
181 }
182 if (defined (my $v = delete $ob->{slow_move})) {
183 $ob->{move_slow} |= MOVE_WALK;
184 $ob->{move_slow_penalty} = $v;
185 }
186 if (defined (my $v = delete $ob->{walk_on})) {
187 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
188 : $ob->{move_on} & ~MOVE_WALK;
189 }
190 if (defined (my $v = delete $ob->{walk_off})) {
191 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
192 : $ob->{move_off} & ~MOVE_WALK;
193 }
194 if (defined (my $v = delete $ob->{fly_on})) {
195 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
196 : $ob->{move_on} & ~MOVE_FLY_LOW;
197 }
198 if (defined (my $v = delete $ob->{fly_off})) {
199 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
200 : $ob->{move_off} & ~MOVE_FLY_LOW;
201 }
202 if (defined (my $v = delete $ob->{flying})) {
203 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
204 : $ob->{move_type} & ~MOVE_FLY_LOW;
205 }
206
207 $ob
208}
48 209
49sub normalize_arch($) { 210sub normalize_arch($) {
50 my ($ob) = @_; 211 my ($ob) = @_;
51 212
213 normalize_object $ob;
214
52 my $arch = $ARCH{$ob->{_name}} 215 my $arch = $ARCH{$ob->{_name}}
53 or (warn "$ob->{_name}: no such archetype", return $ob); 216 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 217
57 if ($arch->{type} == 22) { # map 218 if ($arch->{type} == 22) { # map
58 my %normalize = ( 219 my %normalize = (
59 "enter_x" => "hp", 220 "enter_x" => "hp",
60 "enter_y" => "sp", 221 "enter_y" => "sp",
… …
70 while (my ($k2, $k1) = each %normalize) { 231 while (my ($k2, $k1) = each %normalize) {
71 if (defined (my $v = delete $ob->{$k1})) { 232 if (defined (my $v = delete $ob->{$k1})) {
72 $ob->{$k2} = $v; 233 $ob->{$k2} = $v;
73 } 234 }
74 } 235 }
75 } 236 } 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 237 # if value matches archetype default, delete
102 while (my ($k, $v) = each %$ob) { 238 while (my ($k, $v) = each %$ob) {
103 if (exists $arch->{$k} and $arch->{$k} eq $v) { 239 if (exists $arch->{$k} and $arch->{$k} eq $v) {
104 next if $k eq "_name"; 240 next if $k eq "_name";
105 delete $ob->{$k}; 241 delete $ob->{$k};
106 } 242 }
243 }
244 }
245
246 # a speciality for the editor
247 if (exists $ob->{attack_movement}) {
248 my $am = delete $ob->{attack_movement};
249 $ob->{attack_movement_bits_0_3} = $am & 15;
250 $ob->{attack_movement_bits_4_7} = $am & 240;
107 } 251 }
108 252
109 $ob 253 $ob
110} 254}
111 255
112sub read_pak($;$) { 256sub read_pak($) {
113 my ($path, $cache) = @_; 257 my ($path) = @_;
114 258
115 eval {
116 defined $cache
117 && -M $cache < -M $path
118 && Storable::retrieve $cache
119 } or do {
120 my %pak; 259 my %pak;
121 260
122 open my $fh, "<:raw", $path 261 open my $fh, "<", $path
123 or Carp::croak "$_[0]: $!"; 262 or Carp::croak "$_[0]: $!";
263 binmode $fh;
124 while (<$fh>) { 264 while (<$fh>) {
125 my ($type, $id, $len, $path) = split; 265 my ($type, $id, $len, $path) = split;
126 $path =~ s/.*\///; 266 $path =~ s/.*\///;
127 read $fh, $pak{$path}, $len; 267 read $fh, $pak{$path}, $len;
128 } 268 }
129 269
130 Storable::nstore \%pak, $cache
131 if defined $cache;
132
133 \%pak 270 \%pak
134 }
135} 271}
136 272
137sub read_arch($;$) { 273sub read_arch($) {
138 my ($path, $cache) = @_; 274 my ($path) = @_;
139 275
140 eval {
141 defined $cache
142 && -M $cache < -M $path
143 && Storable::retrieve $cache
144 } or do {
145 my %arc; 276 my %arc;
146 my ($more, $prev); 277 my ($more, $prev);
147 278
148 open my $fh, "<:raw", $path 279 open my $fh, "<", $path
149 or Carp::croak "$path: $!"; 280 or Carp::croak "$path: $!";
150 281
282 binmode $fh;
283
151 my $parse_block; $parse_block = sub { 284 my $parse_block; $parse_block = sub {
152 my %arc = @_; 285 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 286
182 while (<$fh>) { 287 while (<$fh>) {
183 s/\s+$//; 288 s/\s+$//;
184 if (/^more$/i) { 289 if (/^end$/i) {
185 $more = $prev; 290 last;
186 } elsif (/^object (\S+)$/i) { 291 } elsif (/^arch (\S+)$/i) {
187 my $name = $1; 292 push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
188 my $arc = $parse_block->(_name => $name); 293 } elsif (/^lore$/i) {
189 294 while (<$fh>) {
190 if ($more) { 295 last if /^endlore\s*$/i;
191 $more->{more} = $arc;
192 } else {
193 $arc{$name} = $arc; 296 $arc{lore} .= $_;
194 } 297 }
195 $prev = $arc; 298 } elsif (/^msg$/i) {
196 $more = undef; 299 while (<$fh>) {
300 last if /^endmsg\s*$/i;
301 $arc{msg} .= $_;
302 }
197 } elsif (/^arch (\S+)$/i) { 303 } elsif (/^(\S+)\s*(.*)$/) {
198 push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); 304 $arc{lc $1} = $2;
199 } elsif (/^\s*($|#)/) { 305 } elsif (/^\s*($|#)/) {
200 # 306 #
201 } else { 307 } else {
202 warn "$path: unparseable top-level line '$_'"; 308 warn "$path: unparsable line '$_' in arch $arc{_name}";
203 } 309 }
204 } 310 }
205 311
206 undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208 Storable::nstore \%arc, $cache
209 if defined $cache;
210
211 \%arc 312 \%arc
212 } 313 };
314
315 while (<$fh>) {
316 s/\s+$//;
317 if (/^more$/i) {
318 $more = $prev;
319 } elsif (/^object (\S+)$/i) {
320 my $name = $1;
321 my $arc = normalize_object $parse_block->(_name => $name);
322
323 if ($more) {
324 $more->{more} = $arc;
325 } else {
326 $arc{$name} = $arc;
327 }
328 $prev = $arc;
329 $more = undef;
330 } elsif (/^arch (\S+)$/i) {
331 my $name = $1;
332 my $arc = normalize_arch $parse_block->(_name => $name);
333
334 if ($more) {
335 $more->{more} = $arc;
336 } else {
337 push @{ $arc{arch} }, $arc;
338 }
339 $prev = $arc;
340 $more = undef;
341 } elsif (/^\s*($|#)/) {
342 #
343 } else {
344 warn "$path: unparseable top-level line '$_'";
345 }
346 }
347
348 undef $parse_block; # work around bug in perl not freeing $fh etc.
349
350 \%arc
213} 351}
214 352
215# put all archs into a hash with editor_face as it's key 353# put all archs into a hash with editor_face as it's key
216# NOTE: the arrays in the hash values are references to 354# NOTE: the arrays in the hash values are references to
217# the archs from $ARCH 355# the archs from $ARCH
… …
238 my ($a) = @_; 376 my ($a) = @_;
239 377
240 my $o = $ARCH{$a->{_name}} 378 my $o = $ARCH{$a->{_name}}
241 or return; 379 or return;
242 380
243 my $face = $FACE{$a->{face} || $o->{face}} 381 my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
244 or (warn "no face data found for arch '$a->{_name}'"), return; 382 or (warn "no face data found for arch '$a->{_name}'"), return;
245 383
246 if ($face->{w} > 1 || $face->{h} > 1) { 384 if ($face->{w} > 1 || $face->{h} > 1) {
247 # bigface 385 # bigface
248 return (0, 0, $face->{w} - 1, $face->{h} - 1); 386 return (0, 0, $face->{w} - 1, $face->{h} - 1);
… …
264 # single face 402 # single face
265 return (0, 0, 0, 0); 403 return (0, 0, 0, 0);
266 } 404 }
267} 405}
268 406
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 407=item $type = arch_attr $arch
278 408
279Returns a hashref describing the object and its attributes. It can contain 409Returns a hashref describing the object and its attributes. It can contain
280the following keys: 410the following keys:
281 411
282 name the name, suitable for display purposes 412 name the name, suitable for display purposes
283 ignore 413 ignore
284 attr 414 attr
285 desc 415 desc
286 use 416 use
287 section => [name => \%attr, name => \%attr] 417 section => [name => \%attr, name => \%attr]
418 import
288 419
289=cut 420=cut
290 421
291sub arch_attr($) { 422sub arch_attr($) {
292 my ($arch) = @_; 423 my ($obj) = @_;
293 424
294 require Crossfire::Data; 425 require Crossfire::Data;
295 426
296 my %attr; 427 my $root;
428 my $attr = { };
429
430 my $arch = $ARCH{ $obj->{_name} };
431 my $type = $obj->{type} || $arch->{type};
297 432
298 if ($arch->{type} > 0) { 433 if ($type > 0) {
299 %attr = %{ $Crossfire::Data::ATTR{$arch->{type}+0} || {} }; 434 $root = $Crossfire::Data::ATTR{$type};
300 } else { 435 } else {
301 die; 436 my %a = (%$arch, %$obj);
437
438 if ($a{is_floor} && !$a{alive}) {
439 $root = $Crossfire::Data::TYPE{Floor};
440 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
441 $root = $Crossfire::Data::TYPE{"Monster & NPC"};
442 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
443 $root = $Crossfire::Data::TYPE{Wall};
444 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
445 $root = $Crossfire::Data::TYPE{"Weak Wall"};
446 } else {
447 $root = $Crossfire::Data::TYPE{Misc};
448 }
449 }
450
451 my @import = ($root);
302 } 452
453 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
454 unless $type == 116;
303 455
304 use PApp::Util; 456 my (%ignore);
305 warn PApp::Util::dumpval \%attr; 457 my (@section_order, %section, @attr_order);
458
459 while (my $type = shift @import) {
460 push @import, @{$type->{import} || []};
461
462 $attr->{$_} ||= $type->{$_}
463 for qw(name desc use);
464
465 for (@{$type->{ignore} || []}) {
466 $ignore{$_}++ for ref $_ ? @$_ : $_;
467 }
468
469 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
470 my ($name, $attr) = @$_;
471 push @section_order, $name;
472 for (@$attr) {
473 my ($k, $v) = @$_;
474 push @attr_order, $k;
475 $section{$name}{$k} ||= $v;
476 }
477 }
478 }
479
480 $attr->{section} = [
481 map !exists $section{$_} ? () : do {
482 my $attr = delete $section{$_};
483
484 [
485 $_,
486 map exists $attr->{$_} && !$ignore{$_}
487 ? [$_ => delete $attr->{$_}] : (),
488 @attr_order
489 ]
490 },
491
492 exists $section{$_} ? [$_ => delete $section{$_}] : (),
493 @section_order
494 ];
495
496 $attr
306} 497}
307 498
308sub arch_edit_sections { 499sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 500# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 501# edit_type = 0;
… …
364# return(edit_type); 555# return(edit_type);
365# 556#
366# 557#
367} 558}
368 559
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 560sub cache_file($$&&) {
561 my ($src, $cache, $load, $create) = @_;
370 562
371init $CACHEDIR; 563 my ($size, $mtime) = (stat $src)[7,9]
564 or Carp::croak "$src: $!";
565
566 if (-e $cache) {
567 my $ref = eval { load_ref $cache };
568
569 if ($ref->{version} == 1
570 && $ref->{size} == $size
571 && $ref->{mtime} == $mtime
572 && eval { $load->($ref->{data}); 1 }) {
573 return;
574 }
575 }
576
577 my $ref = {
578 version => 1,
579 size => $size,
580 mtime => $mtime,
581 data => $create->(),
582 };
583
584 $load->($ref->{data});
585
586 save_ref $ref, $cache;
587}
588
589=item set_libdir $path
590
591Sets the library directory to the given path
592(default: $ENV{CROSSFIRE_LIBDIR}).
593
594You have to (re-)load the archetypes and tilecache manually after steting
595the library path.
596
597=cut
598
599sub set_libdir($) {
600 $LIB = $_[0];
601}
602
603=item load_archetypes
604
605(Re-)Load archetypes into %ARCH.
606
607=cut
608
609sub load_archetypes() {
610 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
611 *ARCH = $_[0];
612 }, sub {
613 read_arch "$LIB/archetypes"
614 };
615}
616
617=item load_tilecache
618
619(Re-)Load %TILE and %FACE.
620
621=cut
622
623sub load_tilecache() {
624 require Gtk2;
625
626 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
627 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
628 or die "$VARDIR/tilecache.png: $!";
629 *FACE = $_[0];
630 }, sub {
631 my $tile = read_pak "$LIB/crossfire.0";
632
633 my %cache;
634
635 my $idx = 0;
636
637 for my $name (sort keys %$tile) {
638 my $pb = new Gtk2::Gdk::PixbufLoader;
639 $pb->write ($tile->{$name});
640 $pb->close;
641 my $pb = $pb->get_pixbuf;
642
643 my $tile = $cache{$name} = {
644 pb => $pb,
645 idx => $idx,
646 w => int $pb->get_width / TILESIZE,
647 h => int $pb->get_height / TILESIZE,
648 };
649
650
651 $idx += $tile->{w} * $tile->{h};
652 }
653
654 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
655
656 while (my ($name, $tile) = each %cache) {
657 my $tpb = delete $tile->{pb};
658 my $ofs = $tile->{idx};
659
660 for my $x (0 .. $tile->{w} - 1) {
661 for my $y (0 .. $tile->{h} - 1) {
662 my $idx = $ofs + $x + $y * $tile->{w};
663 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
664 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
665 }
666 }
667 }
668
669 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
670
671 \%cache
672 };
673}
372 674
373=head1 AUTHOR 675=head1 AUTHOR
374 676
375 Marc Lehmann <schmorp@schmorp.de> 677 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 678 http://home.schmorp.de/

Diff Legend

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