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

Diff Legend

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