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

Diff Legend

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