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.82 by root, Tue Feb 6 23:53:26 2007 UTC vs.
Revision 1.102 by elmex, Sun Apr 15 11:43:03 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.96'; 9our $VERSION = '0.98';
10 10
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
… …
19 19
20our @EXPORT = qw( 20our @EXPORT = qw(
21 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); 22);
23 23
24use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working 24use JSON::XS qw(from_json to_json);
25
26sub from_json($) {
27 $JSON::Syck::ImplicitUnicode = 1;
28 JSON::Syck::Load $_[0]
29}
30
31sub to_json($) {
32 $JSON::Syck::ImplicitUnicode = 0;
33 JSON::Syck::Dump $_[0]
34}
35 25
36our $LIB = $ENV{CROSSFIRE_LIBDIR}; 26our $LIB = $ENV{CROSSFIRE_LIBDIR};
37 27
38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" 28our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire" 29 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
… …
58 qw(move_type move_block move_allow move_on move_off move_slow); 48 qw(move_type move_block move_allow move_on move_off move_slow);
59 49
60# same as in server save routine, to (hopefully) be compatible 50# same as in server save routine, to (hopefully) be compatible
61# to the other editors. 51# to the other editors.
62our @FIELD_ORDER_MAP = (qw( 52our @FIELD_ORDER_MAP = (qw(
53 file_format_version
63 name attach swap_time reset_timeout fixed_resettime difficulty region 54 name attach swap_time reset_timeout fixed_resettime difficulty region
64 shopitems shopgreed shopmin shopmax shoprace 55 shopitems shopgreed shopmin shopmax shoprace
65 darkness width height enter_x enter_y msg maplore 56 darkness width height enter_x enter_y msg maplore
66 unique template 57 unique template
67 outdoor temp pressure humid windspeed winddir sky nosmooth 58 outdoor temp pressure humid windspeed winddir sky nosmooth
… …
70 61
71our @FIELD_ORDER = (qw( 62our @FIELD_ORDER = (qw(
72 elevation 63 elevation
73 64
74 name name_pl custom_name attach title race 65 name name_pl custom_name attach title race
75 slaying skill msg lore other_arch face 66 slaying skill msg lore other_arch
76 #todo-events 67 is_animated animation face
77 animation is_animated 68 magicmap smoothlevel smoothface
78 str dex con wis pow cha int 69 str dex con wis pow cha int
79 hp maxhp sp maxsp grace maxgrace 70 hp maxhp sp maxsp grace maxgrace
80 exp perm_exp expmul 71 exp perm_exp expmul
81 food dam luck wc ac x y speed speed_left move_state attack_movement 72 food dam luck wc ac x y speed speed_left move_state attack_movement
82 nrof level direction type subtype attacktype 73 nrof level direction type subtype attacktype
… …
138sub MOVE_FLY_HIGH (){ 0x04 } 129sub MOVE_FLY_HIGH (){ 0x04 }
139sub MOVE_FLYING (){ 0x06 } 130sub MOVE_FLYING (){ 0x06 }
140sub MOVE_SWIM (){ 0x08 } 131sub MOVE_SWIM (){ 0x08 }
141sub MOVE_BOAT (){ 0x10 } 132sub MOVE_BOAT (){ 0x10 }
142sub MOVE_KNOWN (){ 0x1f } # all of above 133sub MOVE_KNOWN (){ 0x1f } # all of above
143sub MOVE_ALLBIT (){ 0x10000 }
144sub MOVE_ALL (){ 0x1001f } # very special value, more PITA 134sub MOVE_ALL (){ 0x10000 } # very special value
135
136our %MOVE_TYPE = (
137 walk => MOVE_WALK,
138 fly_low => MOVE_FLY_LOW,
139 fly_high => MOVE_FLY_HIGH,
140 flying => MOVE_FLYING,
141 swim => MOVE_SWIM,
142 boat => MOVE_BOAT,
143 all => MOVE_ALL,
144);
145
146our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat);
147
148{
149 package Crossfire::MoveType;
150
151 use overload
152 '=' => sub { bless [@{$_[0]}], ref $_[0] },
153 '""' => \&as_string,
154 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
155 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
156 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
157 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
158 'x=' => sub {
159 my $cur = $_[0] >= $_[1];
160 if (!defined $cur) {
161 if ($_[0] >= "all") {
162 $_[0] -= $_[1];
163 } else {
164 $_[0] += $_[1];
165 }
166 } elsif ($cur) {
167 $_[0] -= $_[1];
168 } else {
169 $_[0] /= $_[1];
170 }
171
172 $_[0]
173 },
174 'eq' => sub { "$_[0]" eq "$_[1]" },
175 'ne' => sub { "$_[0]" ne "$_[1]" },
176 ;
177}
178
179sub Crossfire::MoveType::new {
180 my ($class, $string) = @_;
181
182 my $mask;
183 my $value;
184
185 if ($string =~ /^\s*\d+\s*$/) {
186 $mask = MOVE_ALL;
187 $value = $string+0;
188 } else {
189 for (split /\s+/, lc $string) {
190 if (s/^-//) {
191 $mask |= $MOVE_TYPE{$_};
192 $value &= ~$MOVE_TYPE{$_};
193 } else {
194 $mask |= $MOVE_TYPE{$_};
195 $value |= $MOVE_TYPE{$_};
196 }
197 }
198 }
199
200 (bless [$mask, $value], $class)->normalise
201}
202
203sub Crossfire::MoveType::normalise {
204 my ($self) = @_;
205
206 if ($self->[0] & MOVE_ALL) {
207 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
208 $self->[0] &= $mask;
209 $self->[1] &= $mask;
210 }
211
212 $self->[1] &= $self->[0];
213
214 $self
215}
216
217sub Crossfire::MoveType::as_string {
218 my ($self) = @_;
219
220 my @res;
221
222 my ($mask, $value) = @$self;
223
224 for (@Crossfire::MOVE_TYPE) {
225 my $bit = $Crossfire::MOVE_TYPE{$_};
226 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
227 $mask &= ~$bit;
228 push @res, $value & $bit ? $_ : "-$_";
229 }
230 }
231
232 join " ", @res
233}
145 234
146sub load_ref($) { 235sub load_ref($) {
147 my ($path) = @_; 236 my ($path) = @_;
148 237
149 open my $fh, "<:raw:perlio", $path 238 open my $fh, "<:raw:perlio", $path
… …
213 adamant => 256, 302 adamant => 256,
214 liquid => 512, 303 liquid => 512,
215 tin => 1024, 304 tin => 1024,
216 bone => 2048, 305 bone => 2048,
217 ice => 4096, 306 ice => 4096,
307
308 # guesses
309 runestone => 12,
310 bronze => 18,
311 "ancient wood" => 20,
312 glass => 36,
313 marble => 66,
314 ice => 68,
315 stone => 70,
316 stone => 80,
317 cloth => 136,
318 ironwood => 144,
319 adamantium => 258,
320 glacium => 260,
321 blood => 544,
218; 322;
219 323
220# object as in "Object xxx", i.e. archetypes 324# object as in "Object xxx", i.e. archetypes
221sub normalize_object($) { 325sub normalize_object($) {
222 my ($ob) = @_; 326 my ($ob) = @_;
… …
230 delete $ob->{material}; 334 delete $ob->{material};
231 } else { 335 } else {
232 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n"; 336 warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n";
233 delete $ob->{material}; # assume materilname is more specific and nuke material 337 delete $ob->{material}; # assume materilname is more specific and nuke material
234 } 338 }
339 } elsif (my $name = $MATERIAL{$ob->{material}}) {
340 delete $ob->{material};
341 $ob->{materialname} = $name;
235 } else { 342 } else {
236 if (my $name = $MATERIAL{$ob->{material}}) { 343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
237 delete $ob->{material};
238 $ob->{materialname} = $name;
239 } 344 }
240 }
241 } 345 }
346
347 # color_fg is used as default for magicmap if magicmap does not exist
348 $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg};
242 349
243 # nuke outdated or never supported fields 350 # nuke outdated or never supported fields
244 delete @$ob{qw( 351 delete @$ob{qw(
245 can_knockback can_parry can_impale can_cut can_dam_armour 352 can_knockback can_parry can_impale can_cut can_dam_armour
246 can_apply pass_thru can_pass_thru 353 can_apply pass_thru can_pass_thru color_bg color_fg
247 )}; 354 )};
248 355
249 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } 356 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
250 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } 357 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
251 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } 358 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
252 359
253 # convert movement strings to bitsets 360 # convert movement strings to bitsets
254 for my $attr (keys %FIELD_MOVEMENT) { 361 for my $attr (keys %FIELD_MOVEMENT) {
255 next unless exists $ob->{$attr}; 362 next unless exists $ob->{$attr};
256 363
257 $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility 364 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr};
258
259 next if $ob->{$attr} =~ /^\d+$/;
260
261 my $flags = 0;
262
263 # assume list
264 for my $flag (map lc, split /\s+/, $ob->{$attr}) {
265 $flags |= MOVE_WALK if $flag eq "walk";
266 $flags |= MOVE_FLY_LOW if $flag eq "fly_low";
267 $flags |= MOVE_FLY_HIGH if $flag eq "fly_high";
268 $flags |= MOVE_FLYING if $flag eq "flying";
269 $flags |= MOVE_SWIM if $flag eq "swim";
270 $flags |= MOVE_BOAT if $flag eq "boat";
271 $flags |= MOVE_ALL if $flag eq "all";
272
273 $flags &= ~MOVE_WALK if $flag eq "-walk";
274 $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
275 $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
276 $flags &= ~MOVE_FLYING if $flag eq "-flying";
277 $flags &= ~MOVE_SWIM if $flag eq "-swim";
278 $flags &= ~MOVE_BOAT if $flag eq "-boat";
279 $flags &= ~MOVE_ALL if $flag eq "-all";
280 }
281
282 $ob->{$attr} = $flags;
283 } 365 }
284 366
285 # convert outdated movement flags to new movement sets 367 # convert outdated movement flags to new movement sets
286 if (defined (my $v = delete $ob->{no_pass})) { 368 if (defined (my $v = delete $ob->{no_pass})) {
287 $ob->{move_block} = $v ? MOVE_ALL : 0; 369 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : "";
288 } 370 }
289 if (defined (my $v = delete $ob->{slow_move})) { 371 if (defined (my $v = delete $ob->{slow_move})) {
290 $ob->{move_slow} |= MOVE_WALK; 372 $ob->{move_slow} += "walk";
291 $ob->{move_slow_penalty} = $v; 373 $ob->{move_slow_penalty} = $v;
292 } 374 }
293 if (defined (my $v = delete $ob->{walk_on})) { 375 if (defined (my $v = delete $ob->{walk_on})) {
294 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; 376 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
295 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
296 : $ob->{move_on} & ~MOVE_WALK;
297 } 377 }
298 if (defined (my $v = delete $ob->{walk_off})) { 378 if (defined (my $v = delete $ob->{walk_off})) {
299 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; 379 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
300 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
301 : $ob->{move_off} & ~MOVE_WALK;
302 } 380 }
303 if (defined (my $v = delete $ob->{fly_on})) { 381 if (defined (my $v = delete $ob->{fly_on})) {
304 $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; 382 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
305 $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
306 : $ob->{move_on} & ~MOVE_FLY_LOW;
307 } 383 }
308 if (defined (my $v = delete $ob->{fly_off})) { 384 if (defined (my $v = delete $ob->{fly_off})) {
309 $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; 385 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
310 $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
311 : $ob->{move_off} & ~MOVE_FLY_LOW;
312 } 386 }
313 if (defined (my $v = delete $ob->{flying})) { 387 if (defined (my $v = delete $ob->{flying})) {
314 $ob->{move_type} = MOVE_ALL unless exists $ob->{move_type}; 388 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
315 $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
316 : $ob->{move_type} & ~MOVE_FLY_LOW;
317 } 389 }
318 390
319 # convert idiotic event_xxx things into objects 391 # convert idiotic event_xxx things into objects
320 while (my ($event, $subtype) = each %EVENT_TYPE) { 392 while (my ($event, $subtype) = each %EVENT_TYPE) {
321 if (exists $ob->{"event_${event}_plugin"}) { 393 if (exists $ob->{"event_${event}_plugin"}) {
… …
552 624
553 my $inv = delete $a{inventory}; 625 my $inv = delete $a{inventory};
554 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some 626 my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some
555 my $anim = delete $a{anim}; 627 my $anim = delete $a{anim};
556 628
629 if ($a{_atype} eq 'object') {
630 $str .= join "\n", "anim", @$anim, "mina\n"
631 if $anim;
632 }
633
557 my @kv; 634 my @kv;
558 635
559 for ($a{_name} eq "map" 636 for ($a{_name} eq "map"
560 ? @Crossfire::FIELD_ORDER_MAP 637 ? @Crossfire::FIELD_ORDER_MAP
561 : @Crossfire::FIELD_ORDER) { 638 : @Crossfire::FIELD_ORDER) {
… …
572 my ($k, $v) = @$_; 649 my ($k, $v) = @$_;
573 650
574 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 651 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) {
575 $v =~ s/\n$//; 652 $v =~ s/\n$//;
576 $str .= "$k\n$v\n$end\n"; 653 $str .= "$k\n$v\n$end\n";
577 } elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) {
578 if ($v & ~Crossfire::MOVE_ALL or !$v) {
579 $str .= "$k $v\n";
580
581 } elsif ($v & Crossfire::MOVE_ALLBIT) {
582 $str .= "$k all";
583
584 $str .= " -walk" unless $v & Crossfire::MOVE_WALK;
585 $str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW;
586 $str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH;
587 $str .= " -swim" unless $v & Crossfire::MOVE_SWIM;
588 $str .= " -boat" unless $v & Crossfire::MOVE_BOAT;
589
590 $str .= "\n";
591
592 } else {
593 $str .= $k;
594
595 $str .= " walk" if $v & Crossfire::MOVE_WALK;
596 $str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW;
597 $str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH;
598 $str .= " swim" if $v & Crossfire::MOVE_SWIM;
599 $str .= " boat" if $v & Crossfire::MOVE_BOAT;
600
601 $str .= "\n";
602 }
603 } else { 654 } else {
604 $str .= "$k $v\n"; 655 $str .= "$k $v\n";
605 } 656 }
606 } 657 }
607 658
608 if ($inv) { 659 if ($inv) {
609 $append->($_) for @$inv; 660 $append->($_) for @$inv;
610 }
611
612 if ($a{_atype} eq 'object') {
613 $str .= join "\n", "anim", @$anim, "mina\n"
614 if $anim;
615 } 661 }
616 662
617 $str .= "end\n"; 663 $str .= "end\n";
618 664
619 if ($a{_atype} eq 'object') { 665 if ($a{_atype} eq 'object') {
… …
780 ]; 826 ];
781 827
782 $attr 828 $attr
783} 829}
784 830
785sub arch_edit_sections {
786# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
787# edit_type = 0;
788# else if (edit_type != 0) {
789# // all flags from 'check_type' must be unset in this arch because they get recalculated now
790# edit_type &= ~check_type;
791# }
792#
793# }
794# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
795# getAttributeValue("alive", defarch) == 1 &&
796# (getAttributeValue("monster", defarch) == 1 ||
797# getAttributeValue("generator", defarch) == 1)) {
798# // Monster: monsters/npcs/generators
799# edit_type |= IGUIConstants.TILE_EDIT_MONSTER;
800# }
801# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
802# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
803# // Walls
804# edit_type |= IGUIConstants.TILE_EDIT_WALL;
805# }
806# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
807# getAttributeValue("connected", defarch) != 0) {
808# // Connected Objects
809# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED;
810# }
811# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
812# arch_type == 66 || arch_type == 41 || arch_type == 95) {
813# // Exit: teleporter/exit/trapdoors
814# edit_type |= IGUIConstants.TILE_EDIT_EXIT;
815# }
816# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
817# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 ||
818# arch_type == 5 || arch_type == 36 || arch_type == 60 ||
819# arch_type == 85 || arch_type == 111 || arch_type == 123 ||
820# arch_type == 124 || arch_type == 130)) {
821# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
822# edit_type |= IGUIConstants.TILE_EDIT_TREASURE;
823# }
824# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
825# arch_type == 20 || arch_type == 23 || arch_type == 26 ||
826# arch_type == 91 || arch_type == 21 || arch_type == 24) {
827# // Door: door/special door/gates + keys
828# edit_type |= IGUIConstants.TILE_EDIT_DOOR;
829# }
830# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
831# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
832# arch_type <= 16) || arch_type == 33 || arch_type == 34 ||
833# arch_type == 35 || arch_type == 39 || arch_type == 70 ||
834# arch_type == 87 || arch_type == 99 || arch_type == 100 ||
835# arch_type == 104 || arch_type == 109 || arch_type == 113 ||
836# arch_type == 122 || arch_type == 3)) {
837# // Equipment: weapons/armour/wands/rods
838# edit_type |= IGUIConstants.TILE_EDIT_EQUIP;
839# }
840#
841# return(edit_type);
842#
843#
844}
845
846sub cache_file($$&&) { 831sub cache_file($$&&) {
847 my ($src, $cache, $load, $create) = @_; 832 my ($src, $cache, $load, $create) = @_;
848 833
849 my ($size, $mtime) = (stat $src)[7,9] 834 my ($size, $mtime) = (stat $src)[7,9]
850 or Carp::croak "$src: $!"; 835 or Carp::croak "$src: $!";
… …
898 }, sub { 883 }, sub {
899 read_arch "$LIB/archetypes" 884 read_arch "$LIB/archetypes"
900 }; 885 };
901} 886}
902 887
888sub construct_tilecache_pb {
889 my ($idx, $cache) = @_;
890
891 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
892
893 while (my ($name, $tile) = each %$cache) {
894 my $tpb = delete $tile->{pb};
895 my $ofs = $tile->{idx};
896
897 for my $x (0 .. $tile->{w} - 1) {
898 for my $y (0 .. $tile->{h} - 1) {
899 my $idx = $ofs + $x + $y * $tile->{w};
900 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
901 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
902 }
903 }
904 }
905
906 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
907
908 $cache
909}
910
911sub use_tilecache {
912 my ($face) = @_;
913 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
914 or die "$VARDIR/tilecache.png: $!";
915 *FACE = $_[0];
916}
917
903=item load_tilecache 918=item load_tilecache
904 919
905(Re-)Load %TILE and %FACE. 920(Re-)Load %TILE and %FACE.
906 921
907=cut 922=cut
908 923
909sub load_tilecache() { 924sub load_tilecache() {
910 require Gtk2; 925 require Gtk2;
911 926
927 if (-e "$LIB/crossfire.0") { # Crossfire1 version
912 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 928 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
913 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 929 sub {
914 or die "$VARDIR/tilecache.png: $!";
915 *FACE = $_[0];
916 }, sub {
917 my $tile = read_pak "$LIB/crossfire.0"; 930 my $tile = read_pak "$LIB/crossfire.0";
918 931
919 my %cache; 932 my %cache;
920 933
921 my $idx = 0; 934 my $idx = 0;
922 935
923 for my $name (sort keys %$tile) { 936 for my $name (sort keys %$tile) {
924 my $pb = new Gtk2::Gdk::PixbufLoader; 937 my $pb = new Gtk2::Gdk::PixbufLoader;
925 $pb->write ($tile->{$name}); 938 $pb->write ($tile->{$name});
926 $pb->close; 939 $pb->close;
927 my $pb = $pb->get_pixbuf; 940 my $pb = $pb->get_pixbuf;
928 941
929 my $tile = $cache{$name} = { 942 my $tile = $cache{$name} = {
930 pb => $pb, 943 pb => $pb,
931 idx => $idx, 944 idx => $idx,
932 w => int $pb->get_width / TILESIZE, 945 w => int $pb->get_width / TILESIZE,
933 h => int $pb->get_height / TILESIZE, 946 h => int $pb->get_height / TILESIZE,
947 };
948
949 $idx += $tile->{w} * $tile->{h};
950 }
951
952 construct_tilecache_pb $idx, \%cache;
953
954 \%cache
934 }; 955 };
956
957 } else { # Crossfire+ version
958 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
959 sub {
960 my %cache;
961 my $facedata = Storable::retrieve "$LIB/facedata";
962
963 $facedata->{version} == 2
964 or die "$LIB/facedata: version mismatch, cannot proceed.";
965
966 my $faces = $facedata->{faceinfo};
967 my $idx = 0;
968
969 for (sort keys %$faces) {
970 my ($face, $info) = ($_, $faces->{$_});
971
972 my $pb = new Gtk2::Gdk::PixbufLoader;
973 $pb->write ($info->{data32});
974 $pb->close;
975 my $pb = $pb->get_pixbuf;
976
977 my $tile = $cache{$face} = {
978 pb => $pb,
979 idx => $idx,
980 w => int $pb->get_width / TILESIZE,
981 h => int $pb->get_height / TILESIZE,
935 982 };
936 983
937 $idx += $tile->{w} * $tile->{h}; 984 $idx += $tile->{w} * $tile->{h};
938 }
939
940 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
941
942 while (my ($name, $tile) = each %cache) {
943 my $tpb = delete $tile->{pb};
944 my $ofs = $tile->{idx};
945
946 for my $x (0 .. $tile->{w} - 1) {
947 for my $y (0 .. $tile->{h} - 1) {
948 my $idx = $ofs + $x + $y * $tile->{w};
949 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
950 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
951 } 985 }
986
987 construct_tilecache_pb $idx, \%cache;
988
989 \%cache
952 } 990 };
953 }
954
955 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
956
957 \%cache
958 }; 991 }
959} 992}
960 993
961=head1 AUTHOR 994=head1 AUTHOR
962 995
963 Marc Lehmann <schmorp@schmorp.de> 996 Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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