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.104 by root, Mon Apr 16 12:32:30 2007 UTC vs.
Revision 1.135 by root, Tue Nov 3 14:56:58 2009 UTC

1=head1 NAME 1=head1 NAME
2 2
3Crossfire - Crossfire maphandling 3Deliantra - Deliantra suppport module to read/write archetypes, maps etc.
4
5=over 4
4 6
5=cut 7=cut
6 8
7package Crossfire; 9package Deliantra;
8 10
9our $VERSION = '0.98'; 11our $VERSION = '1.25';
10 12
11use strict; 13use common::sense;
12 14
13use base 'Exporter'; 15use base 'Exporter';
14 16
15use Carp (); 17use Carp ();
16use File::Spec; 18use File::Spec;
17use List::Util qw(min max); 19use List::Util qw(min max);
18use Storable qw(freeze thaw); 20use Storable qw(freeze thaw);
19 21
20our @EXPORT = qw( 22our @EXPORT = qw(
21 read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents 23 read_pak read_arch
24 *ARCH $TILE *FACE *FACEDATA
25 TILESIZE CACHESTRIDE
26 editor_archs arch_extents
22); 27);
23 28
24use JSON::XS qw(from_json to_json); 29use JSON::XS qw(decode_json encode_json);
25 30
26our $LIB = $ENV{CROSSFIRE_LIBDIR}; 31our $LIB = $ENV{DELIANTRA_LIBDIR};
27 32
28our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" 33our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.deliantra"
29 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire" 34 : $ENV{AppData} ? "$ENV{APPDATA}/deliantra"
30 : File::Spec->tmpdir . "/crossfire"; 35 : File::Spec->tmpdir . "/deliantra";
31 36
32mkdir $VARDIR, 0777; 37mkdir $VARDIR, 0777;
33 38
34sub TILESIZE (){ 32 } 39sub TILESIZE (){ 32 }
40sub CACHESTRIDE (){ 64 }
35 41
36our %ARCH; 42our %ARCH;
43our %FACE; # face32
37our %FACE; 44our %FACEDATA;
38our $TILE; 45our $TILE;
39 46
40our %FIELD_MULTILINE = ( 47our %FIELD_MULTILINE = (
41 msg => "endmsg", 48 msg => "endmsg",
42 lore => "endlore", 49 lore => "endlore",
… …
58 outdoor temp pressure humid windspeed winddir sky nosmooth 65 outdoor temp pressure humid windspeed winddir sky nosmooth
59 tile_path_1 tile_path_2 tile_path_3 tile_path_4 66 tile_path_1 tile_path_2 tile_path_3 tile_path_4
60)); 67));
61 68
62our @FIELD_ORDER = (qw( 69our @FIELD_ORDER = (qw(
70 inherit
71
63 elevation 72 elevation
64 73
65 name name_pl custom_name attach title race 74 name name_pl custom_name attach title race
66 slaying skill msg lore other_arch 75 slaying skill msg lore other_arch
67 face animation is_animated 76 sound sound_destroy face animation is_animated
68 magicmap smoothlevel smoothface 77 magicmap smoothlevel smoothface
69 str dex con wis pow cha int 78 str dex con wis pow cha int
70 hp maxhp sp maxsp grace maxgrace 79 hp maxhp sp maxsp grace maxgrace
71 exp perm_exp expmul 80 exp perm_exp expmul
72 food dam luck wc ac x y speed speed_left move_state attack_movement 81 food dam luck wc ac x y speed speed_left move_state attack_movement
… …
81 resist_life_stealing resist_disease 90 resist_life_stealing resist_disease
82 91
83 path_attuned path_repelled path_denied material materialname 92 path_attuned path_repelled path_denied material materialname
84 value carrying weight invisible state magic 93 value carrying weight invisible state magic
85 last_heal last_sp last_grace last_eat 94 last_heal last_sp last_grace last_eat
86 connected glow_radius randomitems npx_status npc_program 95 connected glow_radius randomitems tresure_env npx_status npc_program
87 run_away pick_up container will_apply smoothlevel 96 run_away pick_up container will_apply smoothlevel
88 current_weapon_script weapontype tooltype elevation client_type 97 current_weapon_script weapontype tooltype elevation client_type
89 item_power duration range 98 item_power duration range
90 range_modifier duration_modifier dam_modifier gen_sp_armour 99 range_modifier duration_modifier dam_modifier gen_sp_armour
91 move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty 100 move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
… …
102 known_magical known_cursed can_use_skill been_applied has_ready_scroll 111 known_magical known_cursed can_use_skill been_applied has_ready_scroll
103 can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly 112 can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
104 has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark 113 has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
105 is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage 114 is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
106 activate_on_push activate_on_release is_water use_content_on_gen is_buildable 115 activate_on_push activate_on_release is_water use_content_on_gen is_buildable
116 precious
107 117
108 body_range body_arm body_torso body_head body_neck body_skill 118 body_range body_arm body_torso body_head body_neck body_skill
109 body_finger body_shoulder body_foot body_hand body_wrist body_waist 119 body_finger body_shoulder body_foot body_hand body_wrist body_waist
110)); 120));
111 121
… …
128sub MOVE_FLY_LOW (){ 0x02 } 138sub MOVE_FLY_LOW (){ 0x02 }
129sub MOVE_FLY_HIGH (){ 0x04 } 139sub MOVE_FLY_HIGH (){ 0x04 }
130sub MOVE_FLYING (){ 0x06 } 140sub MOVE_FLYING (){ 0x06 }
131sub MOVE_SWIM (){ 0x08 } 141sub MOVE_SWIM (){ 0x08 }
132sub MOVE_BOAT (){ 0x10 } 142sub MOVE_BOAT (){ 0x10 }
143sub MOVE_SHIP (){ 0x20 }
133sub MOVE_KNOWN (){ 0x1f } # all of above 144sub MOVE_KNOWN (){ 0x3f } # all of above
134sub MOVE_ALL (){ 0x10000 } # very special value 145sub MOVE_ALL (){ 0x10000 } # very special value
135 146
136our %MOVE_TYPE = ( 147our %MOVE_TYPE = (
137 walk => MOVE_WALK, 148 walk => MOVE_WALK,
138 fly_low => MOVE_FLY_LOW, 149 fly_low => MOVE_FLY_LOW,
139 fly_high => MOVE_FLY_HIGH, 150 fly_high => MOVE_FLY_HIGH,
140 flying => MOVE_FLYING, 151 flying => MOVE_FLYING,
141 swim => MOVE_SWIM, 152 swim => MOVE_SWIM,
142 boat => MOVE_BOAT, 153 boat => MOVE_BOAT,
154 ship => MOVE_SHIP,
143 all => MOVE_ALL, 155 all => MOVE_ALL,
144); 156);
145 157
146our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat); 158our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat ship);
147 159
148{ 160{
149 package Crossfire::MoveType; 161 package Deliantra::MoveType;
150 162
151 use overload 163 use overload
152 '=' => sub { bless [@{$_[0]}], ref $_[0] }, 164 '=' => sub { bless [@{$_[0]}], ref $_[0] },
153 '""' => \&as_string, 165 '""' => \&as_string,
154 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 166 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
… …
172 $_[0] 184 $_[0]
173 }, 185 },
174 'eq' => sub { "$_[0]" eq "$_[1]" }, 186 'eq' => sub { "$_[0]" eq "$_[1]" },
175 'ne' => sub { "$_[0]" ne "$_[1]" }, 187 'ne' => sub { "$_[0]" ne "$_[1]" },
176 ; 188 ;
177}
178 189
179sub Crossfire::MoveType::new { 190 sub TO_JSON {
191 $_[0][0]
192 }
193}
194
195sub Deliantra::MoveType::new {
180 my ($class, $string) = @_; 196 my ($class, $string) = @_;
181 197
182 my $mask; 198 my $mask;
183 my $value; 199 my $value;
184 200
… …
198 } 214 }
199 215
200 (bless [$mask, $value], $class)->normalise 216 (bless [$mask, $value], $class)->normalise
201} 217}
202 218
203sub Crossfire::MoveType::normalise { 219sub Deliantra::MoveType::normalise {
204 my ($self) = @_; 220 my ($self) = @_;
205 221
206 if ($self->[0] & MOVE_ALL) { 222 if ($self->[0] & MOVE_ALL) {
207 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL); 223 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
208 $self->[0] &= $mask; 224 $self->[0] &= $mask;
… …
212 $self->[1] &= $self->[0]; 228 $self->[1] &= $self->[0];
213 229
214 $self 230 $self
215} 231}
216 232
217sub Crossfire::MoveType::as_string { 233sub Deliantra::MoveType::as_string {
218 my ($self) = @_; 234 my ($self) = @_;
219 235
220 my @res; 236 my @res;
221 237
222 my ($mask, $value) = @$self; 238 my ($mask, $value) = @$self;
223 239
224 for (@Crossfire::MOVE_TYPE) { 240 for (@Deliantra::MOVE_TYPE) {
225 my $bit = $Crossfire::MOVE_TYPE{$_}; 241 my $bit = $Deliantra::MOVE_TYPE{$_};
226 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) { 242 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
227 $mask &= ~$bit; 243 $mask &= ~$bit;
228 push @res, $value & $bit ? $_ : "-$_"; 244 push @res, $value & $bit ? $_ : "-$_";
229 } 245 }
230 } 246 }
… …
323 339
324# object as in "Object xxx", i.e. archetypes 340# object as in "Object xxx", i.e. archetypes
325sub normalize_object($) { 341sub normalize_object($) {
326 my ($ob) = @_; 342 my ($ob) = @_;
327 343
344 delete $ob->{editable}; # deprecated
345
328 # convert material bitset to materialname, if possible 346 # convert material bitset to materialname, if possible
329 if (exists $ob->{material}) { 347 if (exists $ob->{material}) {
330 if (!$ob->{material}) { 348 if (!$ob->{material}) {
331 delete $ob->{material}; 349 delete $ob->{material};
332 } elsif (exists $ob->{materialname}) { 350 } elsif (exists $ob->{materialname}) {
… …
342 } else { 360 } else {
343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; 361 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
344 } 362 }
345 } 363 }
346 364
365 # check whether attachment is the same as in the archetype
366 if (exists $ob->{attach}) {
367 my $arch = $ARCH{$ob->{_name}};
368 my $js = JSON::XS->new->utf8->canonical (1);
369
370 if (defined $arch->{attach}
371 && $js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) {
372 delete $ob->{attach}
373 }
374 }
375
347 # color_fg is used as default for magicmap if magicmap does not exist 376 # 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}; 377 $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg};
349 378
350 # nuke outdated or never supported fields 379 # nuke outdated or never supported fields
351 delete @$ob{qw( 380 delete @$ob{qw(
… …
359 388
360 # convert movement strings to bitsets 389 # convert movement strings to bitsets
361 for my $attr (keys %FIELD_MOVEMENT) { 390 for my $attr (keys %FIELD_MOVEMENT) {
362 next unless exists $ob->{$attr}; 391 next unless exists $ob->{$attr};
363 392
364 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr}; 393 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
365 } 394 }
366 395
367 # convert outdated movement flags to new movement sets 396 # convert outdated movement flags to new movement sets
368 if (defined (my $v = delete $ob->{no_pass})) { 397 if (defined (my $v = delete $ob->{no_pass})) {
369 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : ""; 398 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
370 } 399 }
371 if (defined (my $v = delete $ob->{slow_move})) { 400 if (defined (my $v = delete $ob->{slow_move})) {
372 $ob->{move_slow} += "walk"; 401 $ob->{move_slow} += "walk";
373 $ob->{move_slow_penalty} = $v; 402 $ob->{move_slow_penalty} = $v;
374 } 403 }
375 if (defined (my $v = delete $ob->{walk_on})) { 404 if (defined (my $v = delete $ob->{walk_on})) {
376 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" } 405 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
377 } 406 }
378 if (defined (my $v = delete $ob->{walk_off})) { 407 if (defined (my $v = delete $ob->{walk_off})) {
379 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" } 408 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
380 } 409 }
381 if (defined (my $v = delete $ob->{fly_on})) { 410 if (defined (my $v = delete $ob->{fly_on})) {
382 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" } 411 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
383 } 412 }
384 if (defined (my $v = delete $ob->{fly_off})) { 413 if (defined (my $v = delete $ob->{fly_off})) {
385 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" } 414 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
386 } 415 }
387 if (defined (my $v = delete $ob->{flying})) { 416 if (defined (my $v = delete $ob->{flying})) {
388 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" } 417 $ob->{move_type} ||= new Deliantra::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
389 } 418 }
390 419
391 # convert idiotic event_xxx things into objects 420 # convert idiotic event_xxx things into objects
392 while (my ($event, $subtype) = each %EVENT_TYPE) { 421 while (my ($event, $subtype) = each %EVENT_TYPE) {
393 if (exists $ob->{"event_${event}_plugin"}) { 422 if (exists $ob->{"event_${event}_plugin"}) {
… …
409# arch as in "arch xxx", ie.. objects 438# arch as in "arch xxx", ie.. objects
410sub normalize_arch($) { 439sub normalize_arch($) {
411 my ($ob) = @_; 440 my ($ob) = @_;
412 441
413 normalize_object $ob; 442 normalize_object $ob;
443
444 return if $ob->{_atype} eq "object";
414 445
415 my $arch = $ARCH{$ob->{_name}} 446 my $arch = $ARCH{$ob->{_name}}
416 or (warn "$ob->{_name}: no such archetype", return $ob); 447 or (warn "$ob->{_name}: no such archetype", return $ob);
417 448
418 if ($arch->{type} == 22) { # map 449 if ($arch->{type} == 22) { # map
… …
454} 485}
455 486
456sub attr_thaw($) { 487sub attr_thaw($) {
457 my ($ob) = @_; 488 my ($ob) = @_;
458 489
459 $ob->{attach} = from_json $ob->{attach} 490 $ob->{attach} = decode_json $ob->{attach}
460 if exists $ob->{attach}; 491 if exists $ob->{attach};
461 492
462 $ob 493 $ob
463} 494}
464 495
465sub attr_freeze($) { 496sub attr_freeze($) {
466 my ($ob) = @_; 497 my ($ob) = @_;
467 498
468 $ob->{attach} = Crossfire::to_json $ob->{attach} 499 $ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
469 if exists $ob->{attach}; 500 if exists $ob->{attach};
470 501
471 $ob 502 $ob
472} 503}
473 504
… …
493 524
494 my %arc; 525 my %arc;
495 my ($more, $prev); 526 my ($more, $prev);
496 my $comment; 527 my $comment;
497 528
498 open my $fh, "<:raw:perlio:utf8", $path 529 open my $fh, "<:utf8", $path
499 or Carp::croak "$path: $!"; 530 or Carp::croak "$path: $!";
500 531
501# binmode $fh; 532# binmode $fh;
502 533
503 my $parse_block; $parse_block = sub { 534 my $parse_block; $parse_block = sub {
… …
603 my $str; 634 my $str;
604 635
605 my $append; $append = sub { 636 my $append; $append = sub {
606 my %a = %{$_[0]}; 637 my %a = %{$_[0]};
607 638
608 Crossfire::attr_freeze \%a; 639 Deliantra::attr_freeze \%a;
609 Crossfire::normalize_arch \%a; 640 Deliantra::normalize_arch \%a;
610 641
611 # undo the bit-split we did before 642 # undo the bit-split we did before
612 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 643 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
613 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 644 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
614 | (delete $a{attack_movement_bits_4_7}); 645 | (delete $a{attack_movement_bits_4_7});
… …
632 } 663 }
633 664
634 my @kv; 665 my @kv;
635 666
636 for ($a{_name} eq "map" 667 for ($a{_name} eq "map"
637 ? @Crossfire::FIELD_ORDER_MAP 668 ? @Deliantra::FIELD_ORDER_MAP
638 : @Crossfire::FIELD_ORDER) { 669 : @Deliantra::FIELD_ORDER) {
639 push @kv, [$_, delete $a{$_}] 670 push @kv, [$_, delete $a{$_}]
640 if exists $a{$_}; 671 if exists $a{$_};
641 } 672 }
642 673
643 for (sort keys %a) { 674 for (sort keys %a) {
… …
646 } 677 }
647 678
648 for (@kv) { 679 for (@kv) {
649 my ($k, $v) = @$_; 680 my ($k, $v) = @$_;
650 681
651 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 682 if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
652 $v =~ s/\n$//; 683 $v =~ s/\n$//;
653 $str .= "$k\n$v\n$end\n"; 684 $str .= "$k\n$v\n$end\n";
654 } else { 685 } else {
655 $str .= "$k $v\n"; 686 $str .= "$k $v\n";
656 } 687 }
… …
752=cut 783=cut
753 784
754sub arch_attr($) { 785sub arch_attr($) {
755 my ($obj) = @_; 786 my ($obj) = @_;
756 787
757 require Crossfire::Data; 788 require Deliantra::Data;
758 789
759 my $root; 790 my $root;
760 my $attr = { }; 791 my $attr = { };
761 792
762 my $arch = $ARCH{ $obj->{_name} }; 793 my $arch = $ARCH{ $obj->{_name} };
763 my $type = $obj->{type} || $arch->{type}; 794 my $type = $obj->{type} || $arch->{type};
764 795
765 if ($type > 0) { 796 if ($type > 0) {
766 $root = $Crossfire::Data::ATTR{$type}; 797 $root = $Deliantra::Data::ATTR{$type};
767 } else { 798 } else {
768 my %a = (%$arch, %$obj); 799 my %a = (%$arch, %$obj);
769 800
770 if ($a{is_floor} && !$a{alive}) { 801 if ($a{is_floor} && !$a{alive}) {
771 $root = $Crossfire::Data::TYPE{Floor}; 802 $root = $Deliantra::Data::TYPE{Floor};
772 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) { 803 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
773 $root = $Crossfire::Data::TYPE{"Monster & NPC"}; 804 $root = $Deliantra::Data::TYPE{"Monster & NPC"};
774 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) { 805 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
775 $root = $Crossfire::Data::TYPE{Wall}; 806 $root = $Deliantra::Data::TYPE{Wall};
776 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) { 807 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
777 $root = $Crossfire::Data::TYPE{"Weak Wall"}; 808 $root = $Deliantra::Data::TYPE{"Weak Wall"};
778 } else { 809 } else {
779 $root = $Crossfire::Data::TYPE{Misc}; 810 $root = $Deliantra::Data::TYPE{Misc};
780 } 811 }
781 } 812 }
782 813
783 my @import = ($root); 814 my @import = ($root);
784 815
785 unshift @import, \%Crossfire::Data::DEFAULT_ATTR 816 unshift @import, \%Deliantra::Data::DEFAULT_ATTR
786 unless $type == 116; 817 unless $type == 116;
787 818
788 my (%ignore); 819 my (%ignore);
789 my (@section_order, %section, @attr_order); 820 my (@section_order, %section, @attr_order);
790 821
791 while (my $type = shift @import) { 822 while (my $type = shift @import) {
823 push @import,
824 grep $_,
825 map $Deliantra::Data::TYPE{$_},
792 push @import, @{$type->{import} || []}; 826 @{$type->{import} || []};
793 827
794 $attr->{$_} ||= $type->{$_} 828 $attr->{$_} ||= $type->{$_}
795 for qw(name desc use); 829 for qw(name desc use);
796 830
797 for (@{$type->{ignore} || []}) { 831 for (@{$type->{ignore} || []}) {
… …
886} 920}
887 921
888sub construct_tilecache_pb { 922sub construct_tilecache_pb {
889 my ($idx, $cache) = @_; 923 my ($idx, $cache) = @_;
890 924
891 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64; 925 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, CACHESTRIDE * TILESIZE, TILESIZE * int +($idx + CACHESTRIDE - 1) / CACHESTRIDE;
892 926
893 while (my ($name, $tile) = each %$cache) { 927 while (my ($name, $tile) = each %$cache) {
894 my $tpb = delete $tile->{pb}; 928 my $tpb = delete $tile->{pb};
895 my $ofs = $tile->{idx}; 929 my $ofs = $tile->{idx};
896 930
897 for my $x (0 .. $tile->{w} - 1) { 931 for my $x (0 .. $tile->{w} - 1) {
898 for my $y (0 .. $tile->{h} - 1) { 932 for my $y (0 .. $tile->{h} - 1) {
899 my $idx = $ofs + $x + $y * $tile->{w}; 933 my $idx = $ofs + $x + $y * $tile->{w};
900 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE, 934 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
901 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64); 935 $pb, ($idx % CACHESTRIDE) * TILESIZE, TILESIZE * int $idx / CACHESTRIDE);
902 } 936 }
903 } 937 }
904 } 938 }
905 939
906 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1); 940 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
… …
922=cut 956=cut
923 957
924sub load_tilecache() { 958sub load_tilecache() {
925 require Gtk2; 959 require Gtk2;
926 960
927 if (-e "$LIB/crossfire.0") { # Crossfire1 version
928 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
929 sub {
930 my $tile = read_pak "$LIB/crossfire.0";
931
932 my %cache;
933
934 my $idx = 0;
935
936 for my $name (sort keys %$tile) {
937 my $pb = new Gtk2::Gdk::PixbufLoader;
938 $pb->write ($tile->{$name});
939 $pb->close;
940 my $pb = $pb->get_pixbuf;
941
942 my $tile = $cache{$name} = {
943 pb => $pb,
944 idx => $idx,
945 w => int $pb->get_width / 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
955 };
956
957 } else { # Crossfire+ version
958 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache, 961 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
959 sub { 962 sub {
960 my %cache; 963 my %cache;
961 my $facedata = Storable::retrieve "$LIB/facedata"; 964 my $facedata = Storable::retrieve "$LIB/facedata";
962 965
963 $facedata->{version} == 2 966 $facedata->{version} == 2
964 or die "$LIB/facedata: version mismatch, cannot proceed."; 967 or die "$LIB/facedata: version mismatch, cannot proceed.";
965 968
966 my $faces = $facedata->{faceinfo}; 969 my $faces = $facedata->{faceinfo};
967 my $idx = 0; 970 my $idx = 0;
968 971
969 for (sort keys %$faces) { 972 for (sort keys %$faces) {
970 my ($face, $info) = ($_, $faces->{$_}); 973 my ($face, $info) = ($_, $faces->{$_});
971 974
972 my $pb = new Gtk2::Gdk::PixbufLoader; 975 my $pb = new Gtk2::Gdk::PixbufLoader;
973 $pb->write ($info->{data32}); 976 $pb->write ($info->{data32});
974 $pb->close; 977 $pb->close;
975 my $pb = $pb->get_pixbuf; 978 my $pb = $pb->get_pixbuf;
976 979
977 my $tile = $cache{$face} = { 980 my $tile = $cache{$face} = {
978 pb => $pb, 981 pb => $pb,
979 idx => $idx, 982 idx => $idx,
980 w => int $pb->get_width / TILESIZE, 983 w => int $pb->get_width / TILESIZE,
981 h => int $pb->get_height / TILESIZE, 984 h => int $pb->get_height / TILESIZE,
982 }; 985 };
983 986
984 $idx += $tile->{w} * $tile->{h}; 987 $idx += $tile->{w} * $tile->{h};
985 } 988 }
986 989
987 construct_tilecache_pb $idx, \%cache; 990 construct_tilecache_pb $idx, \%cache;
988 991
989 \%cache 992 \%cache
990 }; 993 };
991 }
992} 994}
995
996=back
993 997
994=head1 AUTHOR 998=head1 AUTHOR
995 999
996 Marc Lehmann <schmorp@schmorp.de> 1000 Marc Lehmann <schmorp@schmorp.de>
997 http://home.schmorp.de/ 1001 http://home.schmorp.de/
… …
1000 http://www.ta-sa.org/ 1004 http://www.ta-sa.org/
1001 1005
1002=cut 1006=cut
1003 1007
10041 10081
1009

Diff Legend

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