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.111 by elmex, Thu Jun 7 14:45:22 2007 UTC vs.
Revision 1.142 by root, Sat May 15 00:30:53 2010 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.99'; 11our $VERSION = '1.30';
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",
… …
49 56
50# same as in server save routine, to (hopefully) be compatible 57# same as in server save routine, to (hopefully) be compatible
51# to the other editors. 58# to the other editors.
52our @FIELD_ORDER_MAP = (qw( 59our @FIELD_ORDER_MAP = (qw(
53 file_format_version 60 file_format_version
54 name attach swap_time reset_timeout fixed_resettime difficulty region 61 name attach swap_time reset_timeout fixed_resettime difficulty
62 region music
55 shopitems shopgreed shopmin shopmax shoprace 63 shopitems shopgreed shopmin shopmax shoprace
56 darkness width height enter_x enter_y msg maplore 64 darkness width height enter_x enter_y msg maplore
57 unique template 65 unique template
58 outdoor temp pressure humid windspeed winddir sky nosmooth 66 outdoor temp pressure humid windspeed winddir sky nosmooth
59 tile_path_1 tile_path_2 tile_path_3 tile_path_4 67 tile_path_1 tile_path_2 tile_path_3 tile_path_4
… …
64 72
65 elevation 73 elevation
66 74
67 name name_pl custom_name attach title race 75 name name_pl custom_name attach title race
68 slaying skill msg lore other_arch 76 slaying skill msg lore other_arch
69 face animation is_animated 77 sound sound_destroy face animation is_animated
70 magicmap smoothlevel smoothface 78 magicmap smoothlevel smoothface
71 str dex con wis pow cha int 79 str dex con wis pow cha int
72 hp maxhp sp maxsp grace maxgrace 80 hp maxhp sp maxsp grace maxgrace
73 exp perm_exp expmul 81 exp perm_exp expmul
74 food dam luck wc ac x y speed speed_left move_state attack_movement 82 food dam luck wc ac x y speed speed_left move_state attack_movement
… …
146 boat => MOVE_BOAT, 154 boat => MOVE_BOAT,
147 ship => MOVE_SHIP, 155 ship => MOVE_SHIP,
148 all => MOVE_ALL, 156 all => MOVE_ALL,
149); 157);
150 158
151our @MOVE_TYPE = keys %MOVE_TYPE; 159our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat ship);
152 160
153{ 161{
154 package Crossfire::MoveType; 162 package Deliantra::MoveType;
155 163
156 use overload 164 use overload
157 '=' => sub { bless [@{$_[0]}], ref $_[0] }, 165 '=' => sub { bless [@{$_[0]}], ref $_[0] },
158 '""' => \&as_string, 166 '""' => \&as_string,
159 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 167 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
168 '<=' => sub {
169 ($_[0][0] & $MOVE_TYPE{$_[1]}) == $MOVE_TYPE{$_[1]}
170 ? $_[0][1] & $MOVE_TYPE{$_[1]}
171 : undef
172 },
160 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise }, 173 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
161 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 174 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
162 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 175 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
163 'x=' => sub { 176 'x=' => sub { # toggle between off, + and -
164 my $cur = $_[0] >= $_[1]; 177 my $cur = $_[0] >= $_[1];
165 if (!defined $cur) { 178 if (!defined $cur) {
166 if ($_[0] >= "all") { 179 if ($_[0] >= "all") {
167 $_[0] -= $_[1]; 180 $_[0] -= $_[1];
168 } else { 181 } else {
… …
177 $_[0] 190 $_[0]
178 }, 191 },
179 'eq' => sub { "$_[0]" eq "$_[1]" }, 192 'eq' => sub { "$_[0]" eq "$_[1]" },
180 'ne' => sub { "$_[0]" ne "$_[1]" }, 193 'ne' => sub { "$_[0]" ne "$_[1]" },
181 ; 194 ;
182}
183 195
184sub Crossfire::MoveType::new { 196 sub TO_JSON {
197 $_[0][0]
198 }
199}
200
201sub Deliantra::MoveType::new {
185 my ($class, $string) = @_; 202 my ($class, $string) = @_;
186 203
187 my $mask; 204 my $mask;
188 my $value; 205 my $value;
189 206
… …
203 } 220 }
204 221
205 (bless [$mask, $value], $class)->normalise 222 (bless [$mask, $value], $class)->normalise
206} 223}
207 224
208sub Crossfire::MoveType::normalise { 225sub Deliantra::MoveType::normalise {
209 my ($self) = @_; 226 my ($self) = @_;
210 227
211 if ($self->[0] & MOVE_ALL) { 228 if ($self->[0] & MOVE_ALL) {
212 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL); 229 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
213 $self->[0] &= $mask; 230 $self->[0] &= $mask;
… …
217 $self->[1] &= $self->[0]; 234 $self->[1] &= $self->[0];
218 235
219 $self 236 $self
220} 237}
221 238
222sub Crossfire::MoveType::as_string { 239sub Deliantra::MoveType::as_string {
223 my ($self) = @_; 240 my ($self) = @_;
224 241
225 my @res; 242 my @res;
226 243
227 my ($mask, $value) = @$self; 244 my ($mask, $value) = @$self;
228 245
229 for (@Crossfire::MOVE_TYPE) { 246 for (@Deliantra::MOVE_TYPE) {
230 my $bit = $Crossfire::MOVE_TYPE{$_}; 247 my $bit = $Deliantra::MOVE_TYPE{$_};
231 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) { 248 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
232 $mask &= ~$bit; 249 $mask &= ~$bit;
233 push @res, $value & $bit ? $_ : "-$_"; 250 push @res, $value & $bit ? $_ : "-$_";
234 } 251 }
235 } 252 }
… …
328 345
329# object as in "Object xxx", i.e. archetypes 346# object as in "Object xxx", i.e. archetypes
330sub normalize_object($) { 347sub normalize_object($) {
331 my ($ob) = @_; 348 my ($ob) = @_;
332 349
350 delete $ob->{editable}; # deprecated
351
333 # convert material bitset to materialname, if possible 352 # convert material bitset to materialname, if possible
334 if (exists $ob->{material}) { 353 if (exists $ob->{material}) {
335 if (!$ob->{material}) { 354 if (!$ob->{material}) {
336 delete $ob->{material}; 355 delete $ob->{material};
337 } elsif (exists $ob->{materialname}) { 356 } elsif (exists $ob->{materialname}) {
… …
375 394
376 # convert movement strings to bitsets 395 # convert movement strings to bitsets
377 for my $attr (keys %FIELD_MOVEMENT) { 396 for my $attr (keys %FIELD_MOVEMENT) {
378 next unless exists $ob->{$attr}; 397 next unless exists $ob->{$attr};
379 398
380 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr}; 399 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
381 } 400 }
382 401
383 # convert outdated movement flags to new movement sets 402 # convert outdated movement flags to new movement sets
384 if (defined (my $v = delete $ob->{no_pass})) { 403 if (defined (my $v = delete $ob->{no_pass})) {
385 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : ""; 404 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
386 } 405 }
387 if (defined (my $v = delete $ob->{slow_move})) { 406 if (defined (my $v = delete $ob->{slow_move})) {
388 $ob->{move_slow} += "walk"; 407 $ob->{move_slow} += "walk";
389 $ob->{move_slow_penalty} = $v; 408 $ob->{move_slow_penalty} = $v;
390 } 409 }
391 if (defined (my $v = delete $ob->{walk_on})) { 410 if (defined (my $v = delete $ob->{walk_on})) {
392 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" } 411 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
393 } 412 }
394 if (defined (my $v = delete $ob->{walk_off})) { 413 if (defined (my $v = delete $ob->{walk_off})) {
395 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" } 414 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
396 } 415 }
397 if (defined (my $v = delete $ob->{fly_on})) { 416 if (defined (my $v = delete $ob->{fly_on})) {
398 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" } 417 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
399 } 418 }
400 if (defined (my $v = delete $ob->{fly_off})) { 419 if (defined (my $v = delete $ob->{fly_off})) {
401 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" } 420 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
402 } 421 }
403 if (defined (my $v = delete $ob->{flying})) { 422 if (defined (my $v = delete $ob->{flying})) {
404 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" } 423 $ob->{move_type} ||= new Deliantra::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
405 } 424 }
406 425
407 # convert idiotic event_xxx things into objects 426 # convert idiotic event_xxx things into objects
408 while (my ($event, $subtype) = each %EVENT_TYPE) { 427 while (my ($event, $subtype) = each %EVENT_TYPE) {
409 if (exists $ob->{"event_${event}_plugin"}) { 428 if (exists $ob->{"event_${event}_plugin"}) {
… …
425# arch as in "arch xxx", ie.. objects 444# arch as in "arch xxx", ie.. objects
426sub normalize_arch($) { 445sub normalize_arch($) {
427 my ($ob) = @_; 446 my ($ob) = @_;
428 447
429 normalize_object $ob; 448 normalize_object $ob;
449
450 return if $ob->{_atype} eq "object";
430 451
431 my $arch = $ARCH{$ob->{_name}} 452 my $arch = $ARCH{$ob->{_name}}
432 or (warn "$ob->{_name}: no such archetype", return $ob); 453 or (warn "$ob->{_name}: no such archetype", return $ob);
433 454
434 if ($arch->{type} == 22) { # map 455 if ($arch->{type} == 22) { # map
… …
470} 491}
471 492
472sub attr_thaw($) { 493sub attr_thaw($) {
473 my ($ob) = @_; 494 my ($ob) = @_;
474 495
475 $ob->{attach} = from_json $ob->{attach} 496 $ob->{attach} = decode_json $ob->{attach}
476 if exists $ob->{attach}; 497 if exists $ob->{attach};
477 498
478 $ob 499 $ob
479} 500}
480 501
481sub attr_freeze($) { 502sub attr_freeze($) {
482 my ($ob) = @_; 503 my ($ob) = @_;
483 504
484 $ob->{attach} = Crossfire::to_json $ob->{attach} 505 $ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
485 if exists $ob->{attach}; 506 if exists $ob->{attach};
486 507
487 $ob 508 $ob
488} 509}
489 510
… …
509 530
510 my %arc; 531 my %arc;
511 my ($more, $prev); 532 my ($more, $prev);
512 my $comment; 533 my $comment;
513 534
514 open my $fh, "<:raw:perlio:utf8", $path 535 open my $fh, "<:utf8", $path
515 or Carp::croak "$path: $!"; 536 or Carp::croak "$path: $!";
516 537
517# binmode $fh; 538# binmode $fh;
518 539
519 my $parse_block; $parse_block = sub { 540 my $parse_block; $parse_block = sub {
… …
619 my $str; 640 my $str;
620 641
621 my $append; $append = sub { 642 my $append; $append = sub {
622 my %a = %{$_[0]}; 643 my %a = %{$_[0]};
623 644
624 Crossfire::attr_freeze \%a; 645 Deliantra::attr_freeze \%a;
625 Crossfire::normalize_arch \%a; 646 Deliantra::normalize_arch \%a;
626 647
627 # undo the bit-split we did before 648 # undo the bit-split we did before
628 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 649 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
629 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 650 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
630 | (delete $a{attack_movement_bits_4_7}); 651 | (delete $a{attack_movement_bits_4_7});
… …
648 } 669 }
649 670
650 my @kv; 671 my @kv;
651 672
652 for ($a{_name} eq "map" 673 for ($a{_name} eq "map"
653 ? @Crossfire::FIELD_ORDER_MAP 674 ? @Deliantra::FIELD_ORDER_MAP
654 : @Crossfire::FIELD_ORDER) { 675 : @Deliantra::FIELD_ORDER) {
655 push @kv, [$_, delete $a{$_}] 676 push @kv, [$_, delete $a{$_}]
656 if exists $a{$_}; 677 if exists $a{$_};
657 } 678 }
658 679
659 for (sort keys %a) { 680 for (sort keys %a) {
… …
662 } 683 }
663 684
664 for (@kv) { 685 for (@kv) {
665 my ($k, $v) = @$_; 686 my ($k, $v) = @$_;
666 687
667 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 688 if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
668 $v =~ s/\n$//; 689 $v =~ s/\n$//;
669 $str .= "$k\n$v\n$end\n"; 690 $str .= "$k\n$v\n$end\n";
670 } else { 691 } else {
671 $str .= "$k $v\n"; 692 $str .= "$k $v\n";
672 } 693 }
… …
768=cut 789=cut
769 790
770sub arch_attr($) { 791sub arch_attr($) {
771 my ($obj) = @_; 792 my ($obj) = @_;
772 793
773 require Crossfire::Data; 794 require Deliantra::Data;
774 795
775 my $root; 796 my $root;
776 my $attr = { }; 797 my $attr = { };
777 798
778 my $arch = $ARCH{ $obj->{_name} }; 799 my $arch = $ARCH{ $obj->{_name} };
779 my $type = $obj->{type} || $arch->{type}; 800 my $type = $obj->{type} || $arch->{type};
780 801
781 if ($type > 0) { 802 if ($type > 0) {
782 $root = $Crossfire::Data::ATTR{$type}; 803 $root = $Deliantra::Data::ATTR{$type};
783 } else { 804 } else {
784 my %a = (%$arch, %$obj); 805 my %a = (%$arch, %$obj);
785 806
786 if ($a{is_floor} && !$a{alive}) { 807 if ($a{is_floor} && !$a{alive}) {
787 $root = $Crossfire::Data::TYPE{Floor}; 808 $root = $Deliantra::Data::TYPE{Floor};
788 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) { 809 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
789 $root = $Crossfire::Data::TYPE{"Monster & NPC"}; 810 $root = $Deliantra::Data::TYPE{"Monster & NPC"};
790 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) { 811 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
791 $root = $Crossfire::Data::TYPE{Wall}; 812 $root = $Deliantra::Data::TYPE{Wall};
792 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) { 813 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
793 $root = $Crossfire::Data::TYPE{"Weak Wall"}; 814 $root = $Deliantra::Data::TYPE{"Weak Wall"};
794 } else { 815 } else {
795 $root = $Crossfire::Data::TYPE{Misc}; 816 $root = $Deliantra::Data::TYPE{Misc};
796 } 817 }
797 } 818 }
798 819
820 my (%ignore);
799 my @import = ($root); 821 my @import = ($root);
822
823 my @new_import;
824 while (my $type = shift @import) {
825 # first import everything we will need:
826 push @import,
827 grep $_,
828 map $Deliantra::Data::TYPE{$_},
829 @{$type->{import} || []};
830
831 # and compute the ignored attributes
832 for (@{$type->{ignore} || []}) {
833 $ignore{$_}++ for ref $_ ? @$_ : $_;
834 }
835
836 push @new_import, $type;
800 837 }
838 (@import) = @new_import;
839
840 # then add defaults to the back of the list, so they are added
841 # as last resort.
801 unshift @import, \%Crossfire::Data::DEFAULT_ATTR 842 push @import, \%Deliantra::Data::DEFAULT_ATTR
802 unless $type == 116; 843 unless $type == 116;
803 844
804 my (%ignore);
805 my (@section_order, %section, @attr_order); 845 my (@section_order, %section, @attr_order);
806 846
847 # @import = root, imported, default
807 while (my $type = shift @import) { 848 while (my $type = pop @import) {
808 push @import, @{$type->{import} || []};
809
810 $attr->{$_} ||= $type->{$_} 849 $attr->{$_} ||= $type->{$_}
811 for qw(name desc use); 850 for qw(name desc use);
812
813 for (@{$type->{ignore} || []}) {
814 $ignore{$_}++ for ref $_ ? @$_ : $_;
815 }
816 851
817 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) { 852 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
818 my ($name, $attr) = @$_; 853 my ($name, $attr) = @$_;
819 push @section_order, $name; 854 push @section_order, $name;
820 for (@$attr) { 855 for (@$attr) {
821 my ($k, $v) = @$_; 856 my ($k, $v) = @$_;
822 push @attr_order, $k; 857 push @attr_order, $k;
823 $section{$name}{$k} ||= $v; 858 $section{$name}{$k} = $v; # overwrite, so that the root decides
824 }
825 } 859 }
860 }
861 }
862
863 # remove ignores for "root" type
864 for (
865 map @{$_->[1]}, # section attributes
866 [general => ($root->{attr} || [])],
867 @{$root->{section} || []}
868 ) {
869 my ($k, $v) = @$_;
870 # skip fixed attributes, if they are ignored thats fine
871 next if $v->{type} eq 'fixed';
872
873 delete $ignore{$k}; # if the attributes are defined explicitly they
874 # should NOT be ignored. ignore should mainly
875 # hit imported/inherited attributes.
826 } 876 }
827 877
828 $attr->{section} = [ 878 $attr->{section} = [
829 map !exists $section{$_} ? () : do { 879 map !exists $section{$_} ? () : do {
830 my $attr = delete $section{$_}; 880 my $attr = delete $section{$_};
… …
834 map exists $attr->{$_} && !$ignore{$_} 884 map exists $attr->{$_} && !$ignore{$_}
835 ? [$_ => delete $attr->{$_}] : (), 885 ? [$_ => delete $attr->{$_}] : (),
836 @attr_order 886 @attr_order
837 ] 887 ]
838 }, 888 },
839
840 exists $section{$_} ? [$_ => delete $section{$_}] : (), 889 exists $section{$_} ? [$_ => delete $section{$_}] : (),
841 @section_order 890 @section_order
842 ]; 891 ];
843 892
844 $attr 893 $attr
845} 894}
… …
902} 951}
903 952
904sub construct_tilecache_pb { 953sub construct_tilecache_pb {
905 my ($idx, $cache) = @_; 954 my ($idx, $cache) = @_;
906 955
907 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64; 956 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, CACHESTRIDE * TILESIZE, TILESIZE * int +($idx + CACHESTRIDE - 1) / CACHESTRIDE;
908 957
909 while (my ($name, $tile) = each %$cache) { 958 while (my ($name, $tile) = each %$cache) {
910 my $tpb = delete $tile->{pb}; 959 my $tpb = delete $tile->{pb};
911 my $ofs = $tile->{idx}; 960 my $ofs = $tile->{idx};
912 961
913 for my $x (0 .. $tile->{w} - 1) { 962 for my $x (0 .. $tile->{w} - 1) {
914 for my $y (0 .. $tile->{h} - 1) { 963 for my $y (0 .. $tile->{h} - 1) {
915 my $idx = $ofs + $x + $y * $tile->{w}; 964 my $idx = $ofs + $x + $y * $tile->{w};
916 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE, 965 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
917 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64); 966 $pb, ($idx % CACHESTRIDE) * TILESIZE, TILESIZE * int $idx / CACHESTRIDE);
918 } 967 }
919 } 968 }
920 } 969 }
921 970
922 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1); 971 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
… …
938=cut 987=cut
939 988
940sub load_tilecache() { 989sub load_tilecache() {
941 require Gtk2; 990 require Gtk2;
942 991
943 if (-e "$LIB/facedata") { # Crossfire TRT faces
944 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache, 992 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
945 sub { 993 sub {
946 my %cache; 994 my %cache;
947 my $facedata = Storable::retrieve "$LIB/facedata"; 995 my $facedata = Storable::retrieve "$LIB/facedata";
948 996
949 $facedata->{version} == 2 997 $facedata->{version} == 2
950 or die "$LIB/facedata: version mismatch, cannot proceed."; 998 or die "$LIB/facedata: version mismatch, cannot proceed.";
951 999
952 my $faces = $facedata->{faceinfo}; 1000 my $faces = $facedata->{faceinfo};
953 my $idx = 0; 1001 my $idx = 0;
954 1002
955 for (sort keys %$faces) { 1003 for (sort keys %$faces) {
956 my ($face, $info) = ($_, $faces->{$_}); 1004 my ($face, $info) = ($_, $faces->{$_});
957 1005
958 my $pb = new Gtk2::Gdk::PixbufLoader; 1006 my $pb = new Gtk2::Gdk::PixbufLoader;
959 $pb->write ($info->{data32}); 1007 $pb->write ($info->{data32});
960 $pb->close; 1008 $pb->close;
961 my $pb = $pb->get_pixbuf; 1009 my $pb = $pb->get_pixbuf;
962 1010
963 my $tile = $cache{$face} = { 1011 my $tile = $cache{$face} = {
964 pb => $pb, 1012 pb => $pb,
965 idx => $idx, 1013 idx => $idx,
966 w => int $pb->get_width / TILESIZE, 1014 w => int $pb->get_width / TILESIZE,
967 h => int $pb->get_height / TILESIZE, 1015 h => int $pb->get_height / TILESIZE,
968 }; 1016 };
969 1017
970 $idx += $tile->{w} * $tile->{h}; 1018 $idx += $tile->{w} * $tile->{h};
971 } 1019 }
972 1020
973 construct_tilecache_pb $idx, \%cache; 1021 construct_tilecache_pb $idx, \%cache;
974 1022
975 \%cache 1023 \%cache
976 }; 1024 };
977
978 } elsif (-e "$LIB/crossfire.0") { # Crossfire1 version
979 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
980 sub {
981 my $tile = read_pak "$LIB/crossfire.0";
982
983 my %cache;
984
985 my $idx = 0;
986
987 for my $name (sort keys %$tile) {
988 my $pb = new Gtk2::Gdk::PixbufLoader;
989 $pb->write ($tile->{$name});
990 $pb->close;
991 my $pb = $pb->get_pixbuf;
992
993 my $tile = $cache{$name} = {
994 pb => $pb,
995 idx => $idx,
996 w => int $pb->get_width / TILESIZE,
997 h => int $pb->get_height / TILESIZE,
998 };
999
1000 $idx += $tile->{w} * $tile->{h};
1001 }
1002
1003 construct_tilecache_pb $idx, \%cache;
1004
1005 \%cache
1006 };
1007
1008 }
1009} 1025}
1026
1027=back
1010 1028
1011=head1 AUTHOR 1029=head1 AUTHOR
1012 1030
1013 Marc Lehmann <schmorp@schmorp.de> 1031 Marc Lehmann <schmorp@schmorp.de>
1014 http://home.schmorp.de/ 1032 http://home.schmorp.de/
… …
1017 http://www.ta-sa.org/ 1035 http://www.ta-sa.org/
1018 1036
1019=cut 1037=cut
1020 1038
10211 10391
1040

Diff Legend

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