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.101 by root, Tue Apr 10 09:37:03 2007 UTC vs.
Revision 1.134 by root, Wed Oct 28 10:17:01 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 is_animated animation face 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 }
… …
342 } else { 358 } else {
343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; 359 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
344 } 360 }
345 } 361 }
346 362
363 # check whether attachment is the same as in the archetype
364 if (exists $ob->{attach}) {
365 my $arch = $ARCH{$ob->{_name}};
366 my $js = JSON::XS->new->utf8->canonical (1);
367
368 if (defined $arch->{attach}
369 && $js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) {
370 delete $ob->{attach}
371 }
372 }
373
347 # color_fg is used as default for magicmap if magicmap does not exist 374 # 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}; 375 $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg};
349 376
350 # nuke outdated or never supported fields 377 # nuke outdated or never supported fields
351 delete @$ob{qw( 378 delete @$ob{qw(
… …
359 386
360 # convert movement strings to bitsets 387 # convert movement strings to bitsets
361 for my $attr (keys %FIELD_MOVEMENT) { 388 for my $attr (keys %FIELD_MOVEMENT) {
362 next unless exists $ob->{$attr}; 389 next unless exists $ob->{$attr};
363 390
364 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr}; 391 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
365 } 392 }
366 393
367 # convert outdated movement flags to new movement sets 394 # convert outdated movement flags to new movement sets
368 if (defined (my $v = delete $ob->{no_pass})) { 395 if (defined (my $v = delete $ob->{no_pass})) {
369 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : ""; 396 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
370 } 397 }
371 if (defined (my $v = delete $ob->{slow_move})) { 398 if (defined (my $v = delete $ob->{slow_move})) {
372 $ob->{move_slow} += "walk"; 399 $ob->{move_slow} += "walk";
373 $ob->{move_slow_penalty} = $v; 400 $ob->{move_slow_penalty} = $v;
374 } 401 }
375 if (defined (my $v = delete $ob->{walk_on})) { 402 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" } 403 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
377 } 404 }
378 if (defined (my $v = delete $ob->{walk_off})) { 405 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" } 406 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
380 } 407 }
381 if (defined (my $v = delete $ob->{fly_on})) { 408 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" } 409 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
383 } 410 }
384 if (defined (my $v = delete $ob->{fly_off})) { 411 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" } 412 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
386 } 413 }
387 if (defined (my $v = delete $ob->{flying})) { 414 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" } 415 $ob->{move_type} ||= new Deliantra::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
389 } 416 }
390 417
391 # convert idiotic event_xxx things into objects 418 # convert idiotic event_xxx things into objects
392 while (my ($event, $subtype) = each %EVENT_TYPE) { 419 while (my ($event, $subtype) = each %EVENT_TYPE) {
393 if (exists $ob->{"event_${event}_plugin"}) { 420 if (exists $ob->{"event_${event}_plugin"}) {
… …
409# arch as in "arch xxx", ie.. objects 436# arch as in "arch xxx", ie.. objects
410sub normalize_arch($) { 437sub normalize_arch($) {
411 my ($ob) = @_; 438 my ($ob) = @_;
412 439
413 normalize_object $ob; 440 normalize_object $ob;
441
442 return if $ob->{_atype} eq "object";
414 443
415 my $arch = $ARCH{$ob->{_name}} 444 my $arch = $ARCH{$ob->{_name}}
416 or (warn "$ob->{_name}: no such archetype", return $ob); 445 or (warn "$ob->{_name}: no such archetype", return $ob);
417 446
418 if ($arch->{type} == 22) { # map 447 if ($arch->{type} == 22) { # map
… …
454} 483}
455 484
456sub attr_thaw($) { 485sub attr_thaw($) {
457 my ($ob) = @_; 486 my ($ob) = @_;
458 487
459 $ob->{attach} = from_json $ob->{attach} 488 $ob->{attach} = decode_json $ob->{attach}
460 if exists $ob->{attach}; 489 if exists $ob->{attach};
461 490
462 $ob 491 $ob
463} 492}
464 493
465sub attr_freeze($) { 494sub attr_freeze($) {
466 my ($ob) = @_; 495 my ($ob) = @_;
467 496
468 $ob->{attach} = Crossfire::to_json $ob->{attach} 497 $ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
469 if exists $ob->{attach}; 498 if exists $ob->{attach};
470 499
471 $ob 500 $ob
472} 501}
473 502
… …
493 522
494 my %arc; 523 my %arc;
495 my ($more, $prev); 524 my ($more, $prev);
496 my $comment; 525 my $comment;
497 526
498 open my $fh, "<:raw:perlio:utf8", $path 527 open my $fh, "<:utf8", $path
499 or Carp::croak "$path: $!"; 528 or Carp::croak "$path: $!";
500 529
501# binmode $fh; 530# binmode $fh;
502 531
503 my $parse_block; $parse_block = sub { 532 my $parse_block; $parse_block = sub {
… …
603 my $str; 632 my $str;
604 633
605 my $append; $append = sub { 634 my $append; $append = sub {
606 my %a = %{$_[0]}; 635 my %a = %{$_[0]};
607 636
608 Crossfire::attr_freeze \%a; 637 Deliantra::attr_freeze \%a;
609 Crossfire::normalize_arch \%a; 638 Deliantra::normalize_arch \%a;
610 639
611 # undo the bit-split we did before 640 # undo the bit-split we did before
612 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 641 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}) 642 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
614 | (delete $a{attack_movement_bits_4_7}); 643 | (delete $a{attack_movement_bits_4_7});
… …
632 } 661 }
633 662
634 my @kv; 663 my @kv;
635 664
636 for ($a{_name} eq "map" 665 for ($a{_name} eq "map"
637 ? @Crossfire::FIELD_ORDER_MAP 666 ? @Deliantra::FIELD_ORDER_MAP
638 : @Crossfire::FIELD_ORDER) { 667 : @Deliantra::FIELD_ORDER) {
639 push @kv, [$_, delete $a{$_}] 668 push @kv, [$_, delete $a{$_}]
640 if exists $a{$_}; 669 if exists $a{$_};
641 } 670 }
642 671
643 for (sort keys %a) { 672 for (sort keys %a) {
… …
646 } 675 }
647 676
648 for (@kv) { 677 for (@kv) {
649 my ($k, $v) = @$_; 678 my ($k, $v) = @$_;
650 679
651 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 680 if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
652 $v =~ s/\n$//; 681 $v =~ s/\n$//;
653 $str .= "$k\n$v\n$end\n"; 682 $str .= "$k\n$v\n$end\n";
654 } else { 683 } else {
655 $str .= "$k $v\n"; 684 $str .= "$k $v\n";
656 } 685 }
… …
752=cut 781=cut
753 782
754sub arch_attr($) { 783sub arch_attr($) {
755 my ($obj) = @_; 784 my ($obj) = @_;
756 785
757 require Crossfire::Data; 786 require Deliantra::Data;
758 787
759 my $root; 788 my $root;
760 my $attr = { }; 789 my $attr = { };
761 790
762 my $arch = $ARCH{ $obj->{_name} }; 791 my $arch = $ARCH{ $obj->{_name} };
763 my $type = $obj->{type} || $arch->{type}; 792 my $type = $obj->{type} || $arch->{type};
764 793
765 if ($type > 0) { 794 if ($type > 0) {
766 $root = $Crossfire::Data::ATTR{$type}; 795 $root = $Deliantra::Data::ATTR{$type};
767 } else { 796 } else {
768 my %a = (%$arch, %$obj); 797 my %a = (%$arch, %$obj);
769 798
770 if ($a{is_floor} && !$a{alive}) { 799 if ($a{is_floor} && !$a{alive}) {
771 $root = $Crossfire::Data::TYPE{Floor}; 800 $root = $Deliantra::Data::TYPE{Floor};
772 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) { 801 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
773 $root = $Crossfire::Data::TYPE{"Monster & NPC"}; 802 $root = $Deliantra::Data::TYPE{"Monster & NPC"};
774 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) { 803 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
775 $root = $Crossfire::Data::TYPE{Wall}; 804 $root = $Deliantra::Data::TYPE{Wall};
776 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) { 805 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
777 $root = $Crossfire::Data::TYPE{"Weak Wall"}; 806 $root = $Deliantra::Data::TYPE{"Weak Wall"};
778 } else { 807 } else {
779 $root = $Crossfire::Data::TYPE{Misc}; 808 $root = $Deliantra::Data::TYPE{Misc};
780 } 809 }
781 } 810 }
782 811
783 my @import = ($root); 812 my @import = ($root);
784 813
785 unshift @import, \%Crossfire::Data::DEFAULT_ATTR 814 unshift @import, \%Deliantra::Data::DEFAULT_ATTR
786 unless $type == 116; 815 unless $type == 116;
787 816
788 my (%ignore); 817 my (%ignore);
789 my (@section_order, %section, @attr_order); 818 my (@section_order, %section, @attr_order);
790 819
791 while (my $type = shift @import) { 820 while (my $type = shift @import) {
821 push @import,
822 grep $_,
823 map $Deliantra::Data::TYPE{$_},
792 push @import, @{$type->{import} || []}; 824 @{$type->{import} || []};
793 825
794 $attr->{$_} ||= $type->{$_} 826 $attr->{$_} ||= $type->{$_}
795 for qw(name desc use); 827 for qw(name desc use);
796 828
797 for (@{$type->{ignore} || []}) { 829 for (@{$type->{ignore} || []}) {
… …
883 }, sub { 915 }, sub {
884 read_arch "$LIB/archetypes" 916 read_arch "$LIB/archetypes"
885 }; 917 };
886} 918}
887 919
920sub construct_tilecache_pb {
921 my ($idx, $cache) = @_;
922
923 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, CACHESTRIDE * TILESIZE, TILESIZE * int +($idx + CACHESTRIDE - 1) / CACHESTRIDE;
924
925 while (my ($name, $tile) = each %$cache) {
926 my $tpb = delete $tile->{pb};
927 my $ofs = $tile->{idx};
928
929 for my $x (0 .. $tile->{w} - 1) {
930 for my $y (0 .. $tile->{h} - 1) {
931 my $idx = $ofs + $x + $y * $tile->{w};
932 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
933 $pb, ($idx % CACHESTRIDE) * TILESIZE, TILESIZE * int $idx / CACHESTRIDE);
934 }
935 }
936 }
937
938 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
939
940 $cache
941}
942
943sub use_tilecache {
944 my ($face) = @_;
945 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
946 or die "$VARDIR/tilecache.png: $!";
947 *FACE = $_[0];
948}
949
888=item load_tilecache 950=item load_tilecache
889 951
890(Re-)Load %TILE and %FACE. 952(Re-)Load %TILE and %FACE.
891 953
892=cut 954=cut
893 955
894sub load_tilecache() { 956sub load_tilecache() {
895 require Gtk2; 957 require Gtk2;
896 958
897 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 959 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
898 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
899 or die "$VARDIR/tilecache.png: $!";
900 *FACE = $_[0];
901 }, sub { 960 sub {
902 my $tile = read_pak "$LIB/crossfire.0";
903
904 my %cache; 961 my %cache;
962 my $facedata = Storable::retrieve "$LIB/facedata";
905 963
964 $facedata->{version} == 2
965 or die "$LIB/facedata: version mismatch, cannot proceed.";
966
967 my $faces = $facedata->{faceinfo};
906 my $idx = 0; 968 my $idx = 0;
907 969
908 for my $name (sort keys %$tile) { 970 for (sort keys %$faces) {
971 my ($face, $info) = ($_, $faces->{$_});
972
909 my $pb = new Gtk2::Gdk::PixbufLoader; 973 my $pb = new Gtk2::Gdk::PixbufLoader;
910 $pb->write ($tile->{$name}); 974 $pb->write ($info->{data32});
911 $pb->close; 975 $pb->close;
912 my $pb = $pb->get_pixbuf; 976 my $pb = $pb->get_pixbuf;
913 977
914 my $tile = $cache{$name} = { 978 my $tile = $cache{$face} = {
915 pb => $pb, 979 pb => $pb,
916 idx => $idx, 980 idx => $idx,
917 w => int $pb->get_width / TILESIZE, 981 w => int $pb->get_width / TILESIZE,
918 h => int $pb->get_height / TILESIZE, 982 h => int $pb->get_height / TILESIZE,
919 }; 983 };
920
921 984
922 $idx += $tile->{w} * $tile->{h}; 985 $idx += $tile->{w} * $tile->{h};
986 }
987
988 construct_tilecache_pb $idx, \%cache;
989
990 \%cache
923 } 991 };
924
925 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
926
927 while (my ($name, $tile) = each %cache) {
928 my $tpb = delete $tile->{pb};
929 my $ofs = $tile->{idx};
930
931 for my $x (0 .. $tile->{w} - 1) {
932 for my $y (0 .. $tile->{h} - 1) {
933 my $idx = $ofs + $x + $y * $tile->{w};
934 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
935 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
936 }
937 }
938 }
939
940 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
941
942 \%cache
943 };
944} 992}
993
994=back
945 995
946=head1 AUTHOR 996=head1 AUTHOR
947 997
948 Marc Lehmann <schmorp@schmorp.de> 998 Marc Lehmann <schmorp@schmorp.de>
949 http://home.schmorp.de/ 999 http://home.schmorp.de/
… …
952 http://www.ta-sa.org/ 1002 http://www.ta-sa.org/
953 1003
954=cut 1004=cut
955 1005
9561 10061
1007

Diff Legend

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