--- deliantra/Deliantra/Deliantra.pm 2006/08/31 21:09:32 1.71 +++ deliantra/Deliantra/Deliantra.pm 2007/12/26 18:26:15 1.120 @@ -1,12 +1,12 @@ =head1 NAME -Crossfire - Crossfire maphandling +Deliantra - Deliantra suppport module to read/write archetypes, maps etc. =cut -package Crossfire; +package Deliantra; -our $VERSION = '0.9'; +our $VERSION = '1.14'; use strict; @@ -18,31 +18,32 @@ use Storable qw(freeze thaw); our @EXPORT = qw( - read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents + read_pak read_arch + *ARCH $TILE *FACE *FACEDATA + TILESIZE CACHESTRIDE + editor_archs arch_extents ); -use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working +use JSON::XS qw(decode_json encode_json); -sub from_json($) { - $JSON::Syck::ImplicitUnicode = 1; - JSON::Syck::Load $_[0] -} - -sub to_json($) { - $JSON::Syck::ImplicitUnicode = 0; - JSON::Syck::Dump $_[0] -} +our $LIB = $ENV{DELIANTRA_LIBDIR} || $ENV{CROSSFIRE_LIBDIR}; -our $LIB = $ENV{CROSSFIRE_LIBDIR}; +our $OLDDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" + : $ENV{AppData} ? "$ENV{APPDATA}/crossfire" + : File::Spec->tmpdir . "/crossfire"; -our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire"; +our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.deliantra" + : $ENV{AppData} ? "$ENV{APPDATA}/deliantra" + : File::Spec->tmpdir . "/deliantra"; mkdir $VARDIR, 0777; -sub TILESIZE (){ 32 } +sub TILESIZE (){ 32 } +sub CACHESTRIDE (){ 64 } our %ARCH; -our %FACE; +our %FACE; # face32 +our %FACEDATA; our $TILE; our %FIELD_MULTILINE = ( @@ -58,6 +59,7 @@ # same as in server save routine, to (hopefully) be compatible # to the other editors. our @FIELD_ORDER_MAP = (qw( + file_format_version name attach swap_time reset_timeout fixed_resettime difficulty region shopitems shopgreed shopmin shopmax shoprace darkness width height enter_x enter_y msg maplore @@ -67,12 +69,14 @@ )); our @FIELD_ORDER = (qw( + inherit + elevation name name_pl custom_name attach title race - slaying skill msg lore other_arch face - #todo-events - animation is_animated + slaying skill msg lore other_arch + face animation is_animated + magicmap smoothlevel smoothface str dex con wis pow cha int hp maxhp sp maxsp grace maxgrace exp perm_exp expmul @@ -90,7 +94,7 @@ path_attuned path_repelled path_denied material materialname value carrying weight invisible state magic last_heal last_sp last_grace last_eat - connected glow_radius randomitems npx_status npc_program + connected glow_radius randomitems tresure_env npx_status npc_program run_away pick_up container will_apply smoothlevel current_weapon_script weapontype tooltype elevation client_type item_power duration range @@ -111,6 +115,7 @@ has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage activate_on_push activate_on_release is_water use_content_on_gen is_buildable + precious body_range body_arm body_torso body_head body_neck body_skill body_finger body_shoulder body_foot body_hand body_wrist body_waist @@ -137,9 +142,109 @@ sub MOVE_FLYING (){ 0x06 } sub MOVE_SWIM (){ 0x08 } sub MOVE_BOAT (){ 0x10 } -sub MOVE_KNOWN (){ 0x1f } # all of above -sub MOVE_ALLBIT (){ 0x10000 } -sub MOVE_ALL (){ 0x1001f } # very special value, more PITA +sub MOVE_SHIP (){ 0x20 } +sub MOVE_KNOWN (){ 0x3f } # all of above +sub MOVE_ALL (){ 0x10000 } # very special value + +our %MOVE_TYPE = ( + walk => MOVE_WALK, + fly_low => MOVE_FLY_LOW, + fly_high => MOVE_FLY_HIGH, + flying => MOVE_FLYING, + swim => MOVE_SWIM, + boat => MOVE_BOAT, + ship => MOVE_SHIP, + all => MOVE_ALL, +); + +our @MOVE_TYPE = keys %MOVE_TYPE; + +{ + package Deliantra::MoveType; + + use overload + '=' => sub { bless [@{$_[0]}], ref $_[0] }, + '""' => \&as_string, + '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, + '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise }, + '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise }, + '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, + 'x=' => sub { + my $cur = $_[0] >= $_[1]; + if (!defined $cur) { + if ($_[0] >= "all") { + $_[0] -= $_[1]; + } else { + $_[0] += $_[1]; + } + } elsif ($cur) { + $_[0] -= $_[1]; + } else { + $_[0] /= $_[1]; + } + + $_[0] + }, + 'eq' => sub { "$_[0]" eq "$_[1]" }, + 'ne' => sub { "$_[0]" ne "$_[1]" }, + ; +} + +sub Deliantra::MoveType::new { + my ($class, $string) = @_; + + my $mask; + my $value; + + if ($string =~ /^\s*\d+\s*$/) { + $mask = MOVE_ALL; + $value = $string+0; + } else { + for (split /\s+/, lc $string) { + if (s/^-//) { + $mask |= $MOVE_TYPE{$_}; + $value &= ~$MOVE_TYPE{$_}; + } else { + $mask |= $MOVE_TYPE{$_}; + $value |= $MOVE_TYPE{$_}; + } + } + } + + (bless [$mask, $value], $class)->normalise +} + +sub Deliantra::MoveType::normalise { + my ($self) = @_; + + if ($self->[0] & MOVE_ALL) { + my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL); + $self->[0] &= $mask; + $self->[1] &= $mask; + } + + $self->[1] &= $self->[0]; + + $self +} + +sub Deliantra::MoveType::as_string { + my ($self) = @_; + + my @res; + + my ($mask, $value) = @$self; + + for (@Deliantra::MOVE_TYPE) { + my $bit = $Deliantra::MOVE_TYPE{$_}; + if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) { + $mask &= ~$bit; + push @res, $value & $bit ? $_ : "-$_"; + } + } + + join " ", @res +} sub load_ref($) { my ($path) = @_; @@ -162,80 +267,150 @@ or die "$path: $!"; } +my %attack_mask = ( + physical => 0x00000001, + magic => 0x00000002, + fire => 0x00000004, + electricity => 0x00000008, + cold => 0x00000010, + confusion => 0x00000020, + acid => 0x00000040, + drain => 0x00000080, + weaponmagic => 0x00000100, + ghosthit => 0x00000200, + poison => 0x00000400, + slow => 0x00000800, + paralyze => 0x00001000, + turn_undead => 0x00002000, + fear => 0x00004000, + cancellation => 0x00008000, + deplete => 0x00010000, + death => 0x00020000, + chaos => 0x00040000, + counterspell => 0x00080000, + godpower => 0x00100000, + holyword => 0x00200000, + blind => 0x00400000, + internal => 0x00800000, + life_stealing => 0x01000000, + disease => 0x02000000, +); + +sub _add_resist($$$) { + my ($ob, $mask, $value) = @_; + + while (my ($k, $v) = each %attack_mask) { + $ob->{"resist_$k"} = min 100, max -100, $ob->{"resist_$k"} + $value if $mask & $v; + } +} + +my %MATERIAL = reverse + paper => 1, + iron => 2, + glass => 4, + leather => 8, + wood => 16, + organic => 32, + stone => 64, + cloth => 128, + adamant => 256, + liquid => 512, + tin => 1024, + bone => 2048, + ice => 4096, + + # guesses + runestone => 12, + bronze => 18, + "ancient wood" => 20, + glass => 36, + marble => 66, + ice => 68, + stone => 70, + stone => 80, + cloth => 136, + ironwood => 144, + adamantium => 258, + glacium => 260, + blood => 544, +; + # object as in "Object xxx", i.e. archetypes sub normalize_object($) { my ($ob) = @_; + # convert material bitset to materialname, if possible + if (exists $ob->{material}) { + if (!$ob->{material}) { + delete $ob->{material}; + } elsif (exists $ob->{materialname}) { + if ($MATERIAL{$ob->{material}} eq $ob->{materialname}) { + delete $ob->{material}; + } else { + warn "object $ob->{_name} has both materialname ($ob->{materialname}) and material ($ob->{material}) set.\n"; + delete $ob->{material}; # assume materilname is more specific and nuke material + } + } elsif (my $name = $MATERIAL{$ob->{material}}) { + delete $ob->{material}; + $ob->{materialname} = $name; + } else { + warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; + } + } + + # check whether attachment is the same as in the archetype + if (exists $ob->{attach}) { + my $arch = $ARCH{$ob->{_name}}; + my $js = JSON::XS->new->utf8->canonical (1); + + if (defined $arch->{attach} + && $js->encode ($js->decode ($ob->{attach})) eq $js->encode ($arch->{attach})) { + delete $ob->{attach} + } + } + + # color_fg is used as default for magicmap if magicmap does not exist + $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg}; + # nuke outdated or never supported fields - delete $ob->{$_} for qw( + delete @$ob{qw( can_knockback can_parry can_impale can_cut can_dam_armour - can_apply pass_thru can_pass_thru - ); + can_apply pass_thru can_pass_thru color_bg color_fg + )}; + + if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } + if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } + if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } # convert movement strings to bitsets for my $attr (keys %FIELD_MOVEMENT) { next unless exists $ob->{$attr}; - $ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility - - next if $ob->{$attr} =~ /^\d+$/; - - my $flags = 0; - - # assume list - for my $flag (map lc, split /\s+/, $ob->{$attr}) { - $flags |= MOVE_WALK if $flag eq "walk"; - $flags |= MOVE_FLY_LOW if $flag eq "fly_low"; - $flags |= MOVE_FLY_HIGH if $flag eq "fly_high"; - $flags |= MOVE_FLYING if $flag eq "flying"; - $flags |= MOVE_SWIM if $flag eq "swim"; - $flags |= MOVE_BOAT if $flag eq "boat"; - $flags |= MOVE_ALL if $flag eq "all"; - - $flags &= ~MOVE_WALK if $flag eq "-walk"; - $flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low"; - $flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high"; - $flags &= ~MOVE_FLYING if $flag eq "-flying"; - $flags &= ~MOVE_SWIM if $flag eq "-swim"; - $flags &= ~MOVE_BOAT if $flag eq "-boat"; - $flags &= ~MOVE_ALL if $flag eq "-all"; - } - - $ob->{$attr} = $flags; + $ob->{$attr} = new Deliantra::MoveType $ob->{$attr}; } # convert outdated movement flags to new movement sets if (defined (my $v = delete $ob->{no_pass})) { - $ob->{move_block} = $v ? MOVE_ALL : 0; + $ob->{move_block} = new Deliantra::MoveType $v ? "all" : ""; } if (defined (my $v = delete $ob->{slow_move})) { - $ob->{move_slow} |= MOVE_WALK; + $ob->{move_slow} += "walk"; $ob->{move_slow_penalty} = $v; } if (defined (my $v = delete $ob->{walk_on})) { - $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; - $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK - : $ob->{move_on} & ~MOVE_WALK; + $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" } } if (defined (my $v = delete $ob->{walk_off})) { - $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; - $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK - : $ob->{move_off} & ~MOVE_WALK; + $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" } } if (defined (my $v = delete $ob->{fly_on})) { - $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; - $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW - : $ob->{move_on} & ~MOVE_FLY_LOW; + $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" } } if (defined (my $v = delete $ob->{fly_off})) { - $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; - $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW - : $ob->{move_off} & ~MOVE_FLY_LOW; + $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" } } if (defined (my $v = delete $ob->{flying})) { - $ob->{move_type} = MOVE_ALL unless exists $ob->{move_type}; - $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW - : $ob->{move_type} & ~MOVE_FLY_LOW; + $ob->{move_type} ||= new Deliantra::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" } } # convert idiotic event_xxx things into objects @@ -250,6 +425,9 @@ } } + # some archetypes had "+3" instead of the canonical "3", so fix + $ob->{dam} *= 1 if exists $ob->{dam}; + $ob } @@ -303,7 +481,7 @@ sub attr_thaw($) { my ($ob) = @_; - $ob->{attach} = from_json $ob->{attach} + $ob->{attach} = decode_json $ob->{attach} if exists $ob->{attach}; $ob @@ -312,7 +490,7 @@ sub attr_freeze($) { my ($ob) = @_; - $ob->{attach} = Crossfire::to_json $ob->{attach} + $ob->{attach} = Deliantra::encode_json $ob->{attach} if exists $ob->{attach}; $ob @@ -340,6 +518,7 @@ my %arc; my ($more, $prev); + my $comment; open my $fh, "<:raw:perlio:utf8", $path or Carp::croak "$path: $!"; @@ -353,8 +532,10 @@ s/\s+$//; if (/^end$/i) { last; + } elsif (/^arch (\S+)$/i) { push @{ $arc{inventory} }, attr_thaw normalize_arch $parse_block->(_name => $1); + } elsif (/^lore$/i) { while (<$fh>) { last if /^endlore\s*$/i; @@ -373,7 +554,10 @@ } } elsif (/^(\S+)\s*(.*)$/) { $arc{lc $1} = $2; - } elsif (/^\s*($|#)/) { + } elsif (/^\s*#/) { + $arc{_comment} .= "$_\n"; + + } elsif (/^\s*$/) { # } else { warn "$path: unparsable line '$_' in arch $arc{_name}"; @@ -389,7 +573,9 @@ $more = $prev; } elsif (/^object (\S+)$/i) { my $name = $1; - my $arc = attr_thaw normalize_object $parse_block->(_name => $name); + my $arc = attr_thaw normalize_object $parse_block->(_name => $name, _comment => $comment); + undef $comment; + delete $arc{_comment} unless length $arc{_comment}; $arc->{_atype} = 'object'; if ($more) { @@ -401,7 +587,9 @@ $more = undef; } elsif (/^arch (\S+)$/i) { my $name = $1; - my $arc = attr_thaw normalize_arch $parse_block->(_name => $name); + my $arc = attr_thaw normalize_arch $parse_block->(_name => $name, _comment => $comment); + undef $comment; + delete $arc{_comment} unless length $arc{_comment}; $arc->{_atype} = 'arch'; if ($more) { @@ -420,6 +608,8 @@ } else { $toplevel->{$1} = $2; } + } elsif (/^\s*#/) { + $comment .= "$_\n"; } elsif (/^\s*($|#)/) { # } else { @@ -440,8 +630,8 @@ my $append; $append = sub { my %a = %{$_[0]}; - Crossfire::attr_freeze \%a; - Crossfire::normalize_arch \%a; + Deliantra::attr_freeze \%a; + Deliantra::normalize_arch \%a; # undo the bit-split we did before if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { @@ -449,17 +639,28 @@ | (delete $a{attack_movement_bits_4_7}); } + if (my $comment = delete $a{_comment}) { + if ($comment =~ /[^\n\s#]/) { + $str .= $comment; + } + } + $str .= ((exists $a{_atype}) ? $a{_atype} : 'arch'). " $a{_name}\n"; - my $inv = delete $a{inventory}; + my $inv = delete $a{inventory}; my $more = delete $a{more}; # arches do not support 'more', but old maps can contain some my $anim = delete $a{anim}; + if ($a{_atype} eq 'object') { + $str .= join "\n", "anim", @$anim, "mina\n" + if $anim; + } + my @kv; for ($a{_name} eq "map" - ? @Crossfire::FIELD_ORDER_MAP - : @Crossfire::FIELD_ORDER) { + ? @Deliantra::FIELD_ORDER_MAP + : @Deliantra::FIELD_ORDER) { push @kv, [$_, delete $a{$_}] if exists $a{$_}; } @@ -472,35 +673,9 @@ for (@kv) { my ($k, $v) = @$_; - if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { + if (my $end = $Deliantra::FIELD_MULTILINE{$k}) { $v =~ s/\n$//; $str .= "$k\n$v\n$end\n"; - } elsif (exists $Crossfire::FIELD_MOVEMENT{$k}) { - if ($v & ~Crossfire::MOVE_ALL or !$v) { - $str .= "$k $v\n"; - - } elsif ($v & Crossfire::MOVE_ALLBIT) { - $str .= "$k all"; - - $str .= " -walk" unless $v & Crossfire::MOVE_WALK; - $str .= " -fly_low" unless $v & Crossfire::MOVE_FLY_LOW; - $str .= " -fly_high" unless $v & Crossfire::MOVE_FLY_HIGH; - $str .= " -swim" unless $v & Crossfire::MOVE_SWIM; - $str .= " -boat" unless $v & Crossfire::MOVE_BOAT; - - $str .= "\n"; - - } else { - $str .= $k; - - $str .= " walk" if $v & Crossfire::MOVE_WALK; - $str .= " fly_low" if $v & Crossfire::MOVE_FLY_LOW; - $str .= " fly_high" if $v & Crossfire::MOVE_FLY_HIGH; - $str .= " swim" if $v & Crossfire::MOVE_SWIM; - $str .= " boat" if $v & Crossfire::MOVE_BOAT; - - $str .= "\n"; - } } else { $str .= "$k $v\n"; } @@ -510,16 +685,15 @@ $append->($_) for @$inv; } - if ($a{_atype} eq 'object') { - $str .= join "\n", "anim", @$anim, "mina\n" - if $anim; - } - $str .= "end\n"; - if (($a{_atype} eq 'object') && $more) { - $str .= "\nmore\n"; - $append->($more) if $more; + if ($a{_atype} eq 'object') { + if ($more) { + $str .= "more\n"; + $append->($more) if $more; + } else { + $str .= "\n"; + } } }; @@ -558,8 +732,11 @@ my $o = $ARCH{$a->{_name}} or return; - my $face = $FACE{$a->{face} || $o->{face} || "blank.111"} - or (warn "no face data found for arch '$a->{_name}'"), return; + my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}; + unless ($face) { + $face = $FACE{"blank.x11"} + or (warn "no face data found for arch '$a->{_name}'"), return; + } if ($face->{w} > 1 || $face->{h} > 1) { # bigface @@ -602,7 +779,7 @@ sub arch_attr($) { my ($obj) = @_; - require Crossfire::Data; + require Deliantra::Data; my $root; my $attr = { }; @@ -611,33 +788,36 @@ my $type = $obj->{type} || $arch->{type}; if ($type > 0) { - $root = $Crossfire::Data::ATTR{$type}; + $root = $Deliantra::Data::ATTR{$type}; } else { my %a = (%$arch, %$obj); if ($a{is_floor} && !$a{alive}) { - $root = $Crossfire::Data::TYPE{Floor}; + $root = $Deliantra::Data::TYPE{Floor}; } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) { - $root = $Crossfire::Data::TYPE{"Monster & NPC"}; + $root = $Deliantra::Data::TYPE{"Monster & NPC"}; } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) { - $root = $Crossfire::Data::TYPE{Wall}; + $root = $Deliantra::Data::TYPE{Wall}; } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) { - $root = $Crossfire::Data::TYPE{"Weak Wall"}; + $root = $Deliantra::Data::TYPE{"Weak Wall"}; } else { - $root = $Crossfire::Data::TYPE{Misc}; + $root = $Deliantra::Data::TYPE{Misc}; } } my @import = ($root); - unshift @import, \%Crossfire::Data::DEFAULT_ATTR + unshift @import, \%Deliantra::Data::DEFAULT_ATTR unless $type == 116; my (%ignore); my (@section_order, %section, @attr_order); while (my $type = shift @import) { - push @import, @{$type->{import} || []}; + push @import, + grep $_, + map $Deliantra::Data::TYPE{$_}, + @{$type->{import} || []}; $attr->{$_} ||= $type->{$_} for qw(name desc use); @@ -676,67 +856,6 @@ $attr } -sub arch_edit_sections { -# if (edit_type == IGUIConstants.TILE_EDIT_NONE) -# edit_type = 0; -# else if (edit_type != 0) { -# // all flags from 'check_type' must be unset in this arch because they get recalculated now -# edit_type &= ~check_type; -# } -# -# } -# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 && -# getAttributeValue("alive", defarch) == 1 && -# (getAttributeValue("monster", defarch) == 1 || -# getAttributeValue("generator", defarch) == 1)) { -# // Monster: monsters/npcs/generators -# edit_type |= IGUIConstants.TILE_EDIT_MONSTER; -# } -# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 && -# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) { -# // Walls -# edit_type |= IGUIConstants.TILE_EDIT_WALL; -# } -# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 && -# getAttributeValue("connected", defarch) != 0) { -# // Connected Objects -# edit_type |= IGUIConstants.TILE_EDIT_CONNECTED; -# } -# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 && -# arch_type == 66 || arch_type == 41 || arch_type == 95) { -# // Exit: teleporter/exit/trapdoors -# edit_type |= IGUIConstants.TILE_EDIT_EXIT; -# } -# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 && -# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 || -# arch_type == 5 || arch_type == 36 || arch_type == 60 || -# arch_type == 85 || arch_type == 111 || arch_type == 123 || -# arch_type == 124 || arch_type == 130)) { -# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls -# edit_type |= IGUIConstants.TILE_EDIT_TREASURE; -# } -# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 && -# arch_type == 20 || arch_type == 23 || arch_type == 26 || -# arch_type == 91 || arch_type == 21 || arch_type == 24) { -# // Door: door/special door/gates + keys -# edit_type |= IGUIConstants.TILE_EDIT_DOOR; -# } -# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 && -# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 && -# arch_type <= 16) || arch_type == 33 || arch_type == 34 || -# arch_type == 35 || arch_type == 39 || arch_type == 70 || -# arch_type == 87 || arch_type == 99 || arch_type == 100 || -# arch_type == 104 || arch_type == 109 || arch_type == 113 || -# arch_type == 122 || arch_type == 3)) { -# // Equipment: weapons/armour/wands/rods -# edit_type |= IGUIConstants.TILE_EDIT_EQUIP; -# } -# -# return(edit_type); -# -# -} - sub cache_file($$&&) { my ($src, $cache, $load, $create) = @_; @@ -794,62 +913,78 @@ }; } -=item load_tilecache +sub construct_tilecache_pb { + my ($idx, $cache) = @_; -(Re-)Load %TILE and %FACE. + my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, CACHESTRIDE * TILESIZE, TILESIZE * int +($idx + CACHESTRIDE - 1) / CACHESTRIDE; -=cut + while (my ($name, $tile) = each %$cache) { + my $tpb = delete $tile->{pb}; + my $ofs = $tile->{idx}; + + for my $x (0 .. $tile->{w} - 1) { + for my $y (0 .. $tile->{h} - 1) { + my $idx = $ofs + $x + $y * $tile->{w}; + $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE, + $pb, ($idx % CACHESTRIDE) * TILESIZE, TILESIZE * int $idx / CACHESTRIDE); + } + } + } -sub load_tilecache() { - require Gtk2; + $pb->save ("$VARDIR/tilecache.png", "png", compression => 1); - cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { - $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" - or die "$VARDIR/tilecache.png: $!"; - *FACE = $_[0]; - }, sub { - my $tile = read_pak "$LIB/crossfire.0"; + $cache +} - my %cache; +sub use_tilecache { + my ($face) = @_; + $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" + or die "$VARDIR/tilecache.png: $!"; + *FACE = $_[0]; +} - my $idx = 0; +=item load_tilecache - for my $name (sort keys %$tile) { - my $pb = new Gtk2::Gdk::PixbufLoader; - $pb->write ($tile->{$name}); - $pb->close; - my $pb = $pb->get_pixbuf; - - my $tile = $cache{$name} = { - pb => $pb, - idx => $idx, - w => int $pb->get_width / TILESIZE, - h => int $pb->get_height / TILESIZE, - }; - +(Re-)Load %TILE and %FACE. - $idx += $tile->{w} * $tile->{h}; - } +=cut - my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64; +sub load_tilecache() { + require Gtk2; - while (my ($name, $tile) = each %cache) { - my $tpb = delete $tile->{pb}; - my $ofs = $tile->{idx}; + cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache, + sub { + my %cache; + my $facedata = Storable::retrieve "$LIB/facedata"; + + $facedata->{version} == 2 + or die "$LIB/facedata: version mismatch, cannot proceed."; + + my $faces = $facedata->{faceinfo}; + my $idx = 0; + + for (sort keys %$faces) { + my ($face, $info) = ($_, $faces->{$_}); + + my $pb = new Gtk2::Gdk::PixbufLoader; + $pb->write ($info->{data32}); + $pb->close; + my $pb = $pb->get_pixbuf; + + my $tile = $cache{$face} = { + pb => $pb, + idx => $idx, + w => int $pb->get_width / TILESIZE, + h => int $pb->get_height / TILESIZE, + }; - for my $x (0 .. $tile->{w} - 1) { - for my $y (0 .. $tile->{h} - 1) { - my $idx = $ofs + $x + $y * $tile->{w}; - $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE, - $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64); - } + $idx += $tile->{w} * $tile->{h}; } - } - $pb->save ("$VARDIR/tilecache.png", "png", compression => 1); + construct_tilecache_pb $idx, \%cache; - \%cache - }; + \%cache + }; } =head1 AUTHOR @@ -863,3 +998,4 @@ =cut 1 +