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

Diff Legend

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