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.108 by elmex, Wed May 23 20:21:28 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.98'; 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}) {
… …
352 # check whether attachment is the same as in the archetype 371 # check whether attachment is the same as in the archetype
353 if (exists $ob->{attach}) { 372 if (exists $ob->{attach}) {
354 my $arch = $ARCH{$ob->{_name}}; 373 my $arch = $ARCH{$ob->{_name}};
355 my $js = JSON::XS->new->utf8->canonical (1); 374 my $js = JSON::XS->new->utf8->canonical (1);
356 375
376 if (defined $arch->{attach}
357 if ($js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) { 377 && $js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) {
358 delete $ob->{attach} 378 delete $ob->{attach}
359 } 379 }
360 } 380 }
361 381
362 # color_fg is used as default for magicmap if magicmap does not exist 382 # color_fg is used as default for magicmap if magicmap does not exist
… …
374 394
375 # convert movement strings to bitsets 395 # convert movement strings to bitsets
376 for my $attr (keys %FIELD_MOVEMENT) { 396 for my $attr (keys %FIELD_MOVEMENT) {
377 next unless exists $ob->{$attr}; 397 next unless exists $ob->{$attr};
378 398
379 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr}; 399 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
380 } 400 }
381 401
382 # convert outdated movement flags to new movement sets 402 # convert outdated movement flags to new movement sets
383 if (defined (my $v = delete $ob->{no_pass})) { 403 if (defined (my $v = delete $ob->{no_pass})) {
384 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : ""; 404 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
385 } 405 }
386 if (defined (my $v = delete $ob->{slow_move})) { 406 if (defined (my $v = delete $ob->{slow_move})) {
387 $ob->{move_slow} += "walk"; 407 $ob->{move_slow} += "walk";
388 $ob->{move_slow_penalty} = $v; 408 $ob->{move_slow_penalty} = $v;
389 } 409 }
390 if (defined (my $v = delete $ob->{walk_on})) { 410 if (defined (my $v = delete $ob->{walk_on})) {
391 $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" }
392 } 412 }
393 if (defined (my $v = delete $ob->{walk_off})) { 413 if (defined (my $v = delete $ob->{walk_off})) {
394 $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" }
395 } 415 }
396 if (defined (my $v = delete $ob->{fly_on})) { 416 if (defined (my $v = delete $ob->{fly_on})) {
397 $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" }
398 } 418 }
399 if (defined (my $v = delete $ob->{fly_off})) { 419 if (defined (my $v = delete $ob->{fly_off})) {
400 $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" }
401 } 421 }
402 if (defined (my $v = delete $ob->{flying})) { 422 if (defined (my $v = delete $ob->{flying})) {
403 $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" }
404 } 424 }
405 425
406 # convert idiotic event_xxx things into objects 426 # convert idiotic event_xxx things into objects
407 while (my ($event, $subtype) = each %EVENT_TYPE) { 427 while (my ($event, $subtype) = each %EVENT_TYPE) {
408 if (exists $ob->{"event_${event}_plugin"}) { 428 if (exists $ob->{"event_${event}_plugin"}) {
… …
424# arch as in "arch xxx", ie.. objects 444# arch as in "arch xxx", ie.. objects
425sub normalize_arch($) { 445sub normalize_arch($) {
426 my ($ob) = @_; 446 my ($ob) = @_;
427 447
428 normalize_object $ob; 448 normalize_object $ob;
449
450 return if $ob->{_atype} eq "object";
429 451
430 my $arch = $ARCH{$ob->{_name}} 452 my $arch = $ARCH{$ob->{_name}}
431 or (warn "$ob->{_name}: no such archetype", return $ob); 453 or (warn "$ob->{_name}: no such archetype", return $ob);
432 454
433 if ($arch->{type} == 22) { # map 455 if ($arch->{type} == 22) { # map
… …
469} 491}
470 492
471sub attr_thaw($) { 493sub attr_thaw($) {
472 my ($ob) = @_; 494 my ($ob) = @_;
473 495
474 $ob->{attach} = from_json $ob->{attach} 496 $ob->{attach} = decode_json $ob->{attach}
475 if exists $ob->{attach}; 497 if exists $ob->{attach};
476 498
477 $ob 499 $ob
478} 500}
479 501
480sub attr_freeze($) { 502sub attr_freeze($) {
481 my ($ob) = @_; 503 my ($ob) = @_;
482 504
483 $ob->{attach} = Crossfire::to_json $ob->{attach} 505 $ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
484 if exists $ob->{attach}; 506 if exists $ob->{attach};
485 507
486 $ob 508 $ob
487} 509}
488 510
… …
508 530
509 my %arc; 531 my %arc;
510 my ($more, $prev); 532 my ($more, $prev);
511 my $comment; 533 my $comment;
512 534
513 open my $fh, "<:raw:perlio:utf8", $path 535 open my $fh, "<:utf8", $path
514 or Carp::croak "$path: $!"; 536 or Carp::croak "$path: $!";
515 537
516# binmode $fh; 538# binmode $fh;
517 539
518 my $parse_block; $parse_block = sub { 540 my $parse_block; $parse_block = sub {
… …
618 my $str; 640 my $str;
619 641
620 my $append; $append = sub { 642 my $append; $append = sub {
621 my %a = %{$_[0]}; 643 my %a = %{$_[0]};
622 644
623 Crossfire::attr_freeze \%a; 645 Deliantra::attr_freeze \%a;
624 Crossfire::normalize_arch \%a; 646 Deliantra::normalize_arch \%a;
625 647
626 # undo the bit-split we did before 648 # undo the bit-split we did before
627 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}) {
628 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 650 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
629 | (delete $a{attack_movement_bits_4_7}); 651 | (delete $a{attack_movement_bits_4_7});
… …
647 } 669 }
648 670
649 my @kv; 671 my @kv;
650 672
651 for ($a{_name} eq "map" 673 for ($a{_name} eq "map"
652 ? @Crossfire::FIELD_ORDER_MAP 674 ? @Deliantra::FIELD_ORDER_MAP
653 : @Crossfire::FIELD_ORDER) { 675 : @Deliantra::FIELD_ORDER) {
654 push @kv, [$_, delete $a{$_}] 676 push @kv, [$_, delete $a{$_}]
655 if exists $a{$_}; 677 if exists $a{$_};
656 } 678 }
657 679
658 for (sort keys %a) { 680 for (sort keys %a) {
… …
661 } 683 }
662 684
663 for (@kv) { 685 for (@kv) {
664 my ($k, $v) = @$_; 686 my ($k, $v) = @$_;
665 687
666 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 688 if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
667 $v =~ s/\n$//; 689 $v =~ s/\n$//;
668 $str .= "$k\n$v\n$end\n"; 690 $str .= "$k\n$v\n$end\n";
669 } else { 691 } else {
670 $str .= "$k $v\n"; 692 $str .= "$k $v\n";
671 } 693 }
… …
767=cut 789=cut
768 790
769sub arch_attr($) { 791sub arch_attr($) {
770 my ($obj) = @_; 792 my ($obj) = @_;
771 793
772 require Crossfire::Data; 794 require Deliantra::Data;
773 795
774 my $root; 796 my $root;
775 my $attr = { }; 797 my $attr = { };
776 798
777 my $arch = $ARCH{ $obj->{_name} }; 799 my $arch = $ARCH{ $obj->{_name} };
778 my $type = $obj->{type} || $arch->{type}; 800 my $type = $obj->{type} || $arch->{type};
779 801
780 if ($type > 0) { 802 if ($type > 0) {
781 $root = $Crossfire::Data::ATTR{$type}; 803 $root = $Deliantra::Data::ATTR{$type};
782 } else { 804 } else {
783 my %a = (%$arch, %$obj); 805 my %a = (%$arch, %$obj);
784 806
785 if ($a{is_floor} && !$a{alive}) { 807 if ($a{is_floor} && !$a{alive}) {
786 $root = $Crossfire::Data::TYPE{Floor}; 808 $root = $Deliantra::Data::TYPE{Floor};
787 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) { 809 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
788 $root = $Crossfire::Data::TYPE{"Monster & NPC"}; 810 $root = $Deliantra::Data::TYPE{"Monster & NPC"};
789 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) { 811 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
790 $root = $Crossfire::Data::TYPE{Wall}; 812 $root = $Deliantra::Data::TYPE{Wall};
791 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) { 813 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
792 $root = $Crossfire::Data::TYPE{"Weak Wall"}; 814 $root = $Deliantra::Data::TYPE{"Weak Wall"};
793 } else { 815 } else {
794 $root = $Crossfire::Data::TYPE{Misc}; 816 $root = $Deliantra::Data::TYPE{Misc};
795 } 817 }
796 } 818 }
797 819
820 my (%ignore);
798 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;
799 837 }
838 (@import) = @new_import;
839
840 # then add defaults to the back of the list, so they are added
841 # as last resort.
800 unshift @import, \%Crossfire::Data::DEFAULT_ATTR 842 push @import, \%Deliantra::Data::DEFAULT_ATTR
801 unless $type == 116; 843 unless $type == 116;
802 844
803 my (%ignore);
804 my (@section_order, %section, @attr_order); 845 my (@section_order, %section, @attr_order);
805 846
847 # @import = root, imported, default
806 while (my $type = shift @import) { 848 while (my $type = pop @import) {
807 push @import, @{$type->{import} || []};
808
809 $attr->{$_} ||= $type->{$_} 849 $attr->{$_} ||= $type->{$_}
810 for qw(name desc use); 850 for qw(name desc use);
811
812 for (@{$type->{ignore} || []}) {
813 $ignore{$_}++ for ref $_ ? @$_ : $_;
814 }
815 851
816 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) { 852 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
817 my ($name, $attr) = @$_; 853 my ($name, $attr) = @$_;
818 push @section_order, $name; 854 push @section_order, $name;
819 for (@$attr) { 855 for (@$attr) {
820 my ($k, $v) = @$_; 856 my ($k, $v) = @$_;
821 push @attr_order, $k; 857 push @attr_order, $k;
822 $section{$name}{$k} ||= $v; 858 $section{$name}{$k} = $v; # overwrite, so that the root decides
823 }
824 } 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.
825 } 876 }
826 877
827 $attr->{section} = [ 878 $attr->{section} = [
828 map !exists $section{$_} ? () : do { 879 map !exists $section{$_} ? () : do {
829 my $attr = delete $section{$_}; 880 my $attr = delete $section{$_};
… …
833 map exists $attr->{$_} && !$ignore{$_} 884 map exists $attr->{$_} && !$ignore{$_}
834 ? [$_ => delete $attr->{$_}] : (), 885 ? [$_ => delete $attr->{$_}] : (),
835 @attr_order 886 @attr_order
836 ] 887 ]
837 }, 888 },
838
839 exists $section{$_} ? [$_ => delete $section{$_}] : (), 889 exists $section{$_} ? [$_ => delete $section{$_}] : (),
840 @section_order 890 @section_order
841 ]; 891 ];
842 892
843 $attr 893 $attr
844} 894}
… …
901} 951}
902 952
903sub construct_tilecache_pb { 953sub construct_tilecache_pb {
904 my ($idx, $cache) = @_; 954 my ($idx, $cache) = @_;
905 955
906 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;
907 957
908 while (my ($name, $tile) = each %$cache) { 958 while (my ($name, $tile) = each %$cache) {
909 my $tpb = delete $tile->{pb}; 959 my $tpb = delete $tile->{pb};
910 my $ofs = $tile->{idx}; 960 my $ofs = $tile->{idx};
911 961
912 for my $x (0 .. $tile->{w} - 1) { 962 for my $x (0 .. $tile->{w} - 1) {
913 for my $y (0 .. $tile->{h} - 1) { 963 for my $y (0 .. $tile->{h} - 1) {
914 my $idx = $ofs + $x + $y * $tile->{w}; 964 my $idx = $ofs + $x + $y * $tile->{w};
915 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE, 965 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
916 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64); 966 $pb, ($idx % CACHESTRIDE) * TILESIZE, TILESIZE * int $idx / CACHESTRIDE);
917 } 967 }
918 } 968 }
919 } 969 }
920 970
921 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1); 971 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
… …
937=cut 987=cut
938 988
939sub load_tilecache() { 989sub load_tilecache() {
940 require Gtk2; 990 require Gtk2;
941 991
942 if (-e "$LIB/crossfire.0") { # Crossfire1 version
943 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
944 sub {
945 my $tile = read_pak "$LIB/crossfire.0";
946
947 my %cache;
948
949 my $idx = 0;
950
951 for my $name (sort keys %$tile) {
952 my $pb = new Gtk2::Gdk::PixbufLoader;
953 $pb->write ($tile->{$name});
954 $pb->close;
955 my $pb = $pb->get_pixbuf;
956
957 my $tile = $cache{$name} = {
958 pb => $pb,
959 idx => $idx,
960 w => int $pb->get_width / TILESIZE,
961 h => int $pb->get_height / TILESIZE,
962 };
963
964 $idx += $tile->{w} * $tile->{h};
965 }
966
967 construct_tilecache_pb $idx, \%cache;
968
969 \%cache
970 };
971
972 } else { # Crossfire+ version
973 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache, 992 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
974 sub { 993 sub {
975 my %cache; 994 my %cache;
976 my $facedata = Storable::retrieve "$LIB/facedata"; 995 my $facedata = Storable::retrieve "$LIB/facedata";
977 996
978 $facedata->{version} == 2 997 $facedata->{version} == 2
979 or die "$LIB/facedata: version mismatch, cannot proceed."; 998 or die "$LIB/facedata: version mismatch, cannot proceed.";
980 999
981 my $faces = $facedata->{faceinfo}; 1000 my $faces = $facedata->{faceinfo};
982 my $idx = 0; 1001 my $idx = 0;
983 1002
984 for (sort keys %$faces) { 1003 for (sort keys %$faces) {
985 my ($face, $info) = ($_, $faces->{$_}); 1004 my ($face, $info) = ($_, $faces->{$_});
986 1005
987 my $pb = new Gtk2::Gdk::PixbufLoader; 1006 my $pb = new Gtk2::Gdk::PixbufLoader;
988 $pb->write ($info->{data32}); 1007 $pb->write ($info->{data32});
989 $pb->close; 1008 $pb->close;
990 my $pb = $pb->get_pixbuf; 1009 my $pb = $pb->get_pixbuf;
991 1010
992 my $tile = $cache{$face} = { 1011 my $tile = $cache{$face} = {
993 pb => $pb, 1012 pb => $pb,
994 idx => $idx, 1013 idx => $idx,
995 w => int $pb->get_width / TILESIZE, 1014 w => int $pb->get_width / TILESIZE,
996 h => int $pb->get_height / TILESIZE, 1015 h => int $pb->get_height / TILESIZE,
997 }; 1016 };
998 1017
999 $idx += $tile->{w} * $tile->{h}; 1018 $idx += $tile->{w} * $tile->{h};
1000 } 1019 }
1001 1020
1002 construct_tilecache_pb $idx, \%cache; 1021 construct_tilecache_pb $idx, \%cache;
1003 1022
1004 \%cache 1023 \%cache
1005 }; 1024 };
1006 }
1007} 1025}
1026
1027=back
1008 1028
1009=head1 AUTHOR 1029=head1 AUTHOR
1010 1030
1011 Marc Lehmann <schmorp@schmorp.de> 1031 Marc Lehmann <schmorp@schmorp.de>
1012 http://home.schmorp.de/ 1032 http://home.schmorp.de/
… …
1015 http://www.ta-sa.org/ 1035 http://www.ta-sa.org/
1016 1036
1017=cut 1037=cut
1018 1038
10191 10391
1040

Diff Legend

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