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.59 by root, Sun Mar 26 11:52:31 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 }
204 } 309 }
205 310 }
206 undef $parse_block; # work around bug in perl not freeing $fh etc.
207
208 Storable::nstore \%arc, $cache
209 if defined $cache;
210 311
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 $root = $Crossfire::Data::TYPE{Misc};
437
438 type:
439 for (@Crossfire::Data::ATTR0) {
440 my $req = $_->{required}
441 or die "internal error: ATTR0 without 'required'";
442
443 keys %$req;
444 while (my ($k, $v) = each %$req) {
445 next type
446 unless $obj->{$k} == $v || $arch->{$k} == $v;
447 }
448
449 $root = $_;
450 }
451 }
452
453 my @import = ($root);
302 } 454
455 unshift @import, \%Crossfire::Data::DEFAULT_ATTR
456 unless $type == 116;
303 457
304 use PApp::Util; 458 my (%ignore);
305 warn PApp::Util::dumpval \%attr; 459 my (@section_order, %section, @attr_order);
460
461 while (my $type = shift @import) {
462 push @import, @{$type->{import} || []};
463
464 $attr->{$_} ||= $type->{$_}
465 for qw(name desc use);
466
467 for (@{$type->{ignore} || []}) {
468 $ignore{$_}++ for ref $_ ? @$_ : $_;
469 }
470
471 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
472 my ($name, $attr) = @$_;
473 push @section_order, $name;
474 for (@$attr) {
475 my ($k, $v) = @$_;
476 push @attr_order, $k;
477 $section{$name}{$k} ||= $v;
478 }
479 }
480 }
481
482 $attr->{section} = [
483 map !exists $section{$_} ? () : do {
484 my $attr = delete $section{$_};
485
486 [
487 $_,
488 map exists $attr->{$_} && !$ignore{$_}
489 ? [$_ => delete $attr->{$_}] : (),
490 @attr_order
491 ]
492 },
493
494 exists $section{$_} ? [$_ => delete $section{$_}] : (),
495 @section_order
496 ];
497
498 $attr
306} 499}
307 500
308sub arch_edit_sections { 501sub arch_edit_sections {
309# if (edit_type == IGUIConstants.TILE_EDIT_NONE) 502# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
310# edit_type = 0; 503# edit_type = 0;
… …
364# return(edit_type); 557# return(edit_type);
365# 558#
366# 559#
367} 560}
368 561
369$CACHEDIR ||= "$ENV{HOME}/.crossfire"; 562sub cache_file($$&&) {
563 my ($src, $cache, $load, $create) = @_;
370 564
371init $CACHEDIR; 565 my ($size, $mtime) = (stat $src)[7,9]
566 or Carp::croak "$src: $!";
567
568 if (-e $cache) {
569 my $ref = eval { load_ref $cache };
570
571 if ($ref->{version} == 1
572 && $ref->{size} == $size
573 && $ref->{mtime} == $mtime
574 && eval { $load->($ref->{data}); 1 }) {
575 return;
576 }
577 }
578
579 my $ref = {
580 version => 1,
581 size => $size,
582 mtime => $mtime,
583 data => $create->(),
584 };
585
586 $load->($ref->{data});
587
588 save_ref $ref, $cache;
589}
590
591=item set_libdir $path
592
593Sets the library directory to the given path
594(default: $ENV{CROSSFIRE_LIBDIR}).
595
596You have to (re-)load the archetypes and tilecache manually after steting
597the library path.
598
599=cut
600
601sub set_libdir($) {
602 $LIB = $_[0];
603}
604
605=item load_archetypes
606
607(Re-)Load archetypes into %ARCH.
608
609=cut
610
611sub load_archetypes() {
612 cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
613 *ARCH = $_[0];
614 }, sub {
615 read_arch "$LIB/archetypes"
616 };
617}
618
619=item load_tilecache
620
621(Re-)Load %TILE and %FACE.
622
623=cut
624
625sub load_tilecache() {
626 require Gtk2;
627
628 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
629 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
630 or die "$VARDIR/tilecache.png: $!";
631 *FACE = $_[0];
632 }, sub {
633 require File::Temp;
634
635 my $tile = read_pak "$LIB/crossfire.0";
636
637 my %cache;
638
639 my $idx = 0;
640
641 for my $name (sort keys %$tile) {
642 my ($fh, $filename) = File::Temp::tempfile ();
643 print $fh $tile->{$name};
644 close $fh;
645 my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;
646 unlink $filename;
647
648 my $tile = $cache{$name} = {
649 pb => $pb,
650 idx => $idx,
651 w => int $pb->get_width / TILESIZE,
652 h => int $pb->get_height / TILESIZE,
653 };
654
655
656 $idx += $tile->{w} * $tile->{h};
657 }
658
659 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
660
661 while (my ($name, $tile) = each %cache) {
662 my $tpb = delete $tile->{pb};
663 my $ofs = $tile->{idx};
664
665 for my $x (0 .. $tile->{w} - 1) {
666 for my $y (0 .. $tile->{h} - 1) {
667 my $idx = $ofs + $x + $y * $tile->{w};
668 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
669 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
670 }
671 }
672 }
673
674 $pb->save ("$VARDIR/tilecache.png", "png");
675
676 \%cache
677 };
678}
372 679
373=head1 AUTHOR 680=head1 AUTHOR
374 681
375 Marc Lehmann <schmorp@schmorp.de> 682 Marc Lehmann <schmorp@schmorp.de>
376 http://home.schmorp.de/ 683 http://home.schmorp.de/

Diff Legend

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