deliantra/Deliantra/Deliantra.pm

=head1 NAME

Crossfire - Crossfire maphandling

=cut

package Crossfire;

our $VERSION = '0.1';

use strict;

use base 'Exporter';

use Carp ();
use File::Spec;
use List::Util qw(min max);
use Storable qw(freeze thaw);

our @EXPORT = qw(
   read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents
);

our $LIB = $ENV{CROSSFIRE_LIBDIR};

our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";

mkdir $VARDIR, 0777;

sub TILESIZE (){ 32 }

our %ARCH;
our %FACE;
our $TILE;

our %FIELD_MULTILINE = (
   msg     => "endmsg",
   lore    => "endlore",
   maplore => "endmaplore",
);

# movement bit type, PITA
our %FIELD_MOVEMENT = map +($_ => undef),
   qw(move_type move_block move_allow move_on move_off move_slow);

# same as in server save routine, to (hopefully) be compatible
# to the other editors.
our @FIELD_ORDER_MAP = (qw(
   name swap_time reset_timeout fixed_resettime difficulty region
   shopitems shopgreed shopmin shopmax shoprace
   darkness width height enter_x enter_y msg maplore
   unique template
   outdoor temp pressure humid windspeed winddir sky nosmooth
   tile_path_1 tile_path_2 tile_path_3 tile_path_4
));

our @FIELD_ORDER = (qw(
   elevation

   name name_pl custom_name title race
   slaying skill msg lore other_arch face
   #todo-events
   animation is_animated
   str dex con wis pow cha int
   hp maxhp sp maxsp grace maxgrace
   exp perm_exp expmul
   food dam luck wc ac x y speed speed_left move_state attack_movement
   nrof level direction type subtype attacktype

   resist_physical resist_magic resist_fire resist_electricity 
   resist_cold resist_confusion resist_acid resist_drain 
   resist_weaponmagic resist_ghosthit resist_poison resist_slow 
   resist_paralyze resist_turn_undead resist_fear resist_cancellation 
   resist_deplete resist_death resist_chaos resist_counterspell 
   resist_godpower resist_holyword resist_blind resist_internal 
   resist_life_stealing resist_disease

   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
   run_away pick_up container will_apply smoothlevel
   current_weapon_script weapontype tooltype elevation client_type
   item_power duration range
   range_modifier duration_modifier dam_modifier gen_sp_armour
   move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty

   alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
   friendly generator is_thrown auto_apply treasure player sold see_invisible
   can_roll overlay_floor is_turnable is_used_up identified reflecting changing
   splitting hitback startequip blocksview undead scared unaggressive
   reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
   run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
   can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
   has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
   random_move only_attack confused stealth cursed damned see_anywhere
   known_magical known_cursed can_use_skill been_applied has_ready_scroll
   can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
   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

   body_range body_arm body_torso body_head body_neck body_skill
   body_finger body_shoulder body_foot body_hand body_wrist body_waist
));

our %EVENT_TYPE = (
   apply   =>  1,
   attack  =>  2,
   death   =>  3,
   drop    =>  4,
   pickup  =>  5,
   say     =>  6,
   stop    =>  7,
   time    =>  8,
   throw   =>  9,
   trigger => 10,
   close   => 11,
   timer   => 12,
);

sub MOVE_WALK      (){ 0x01 }
sub MOVE_FLY_LOW   (){ 0x02 }
sub MOVE_FLY_HIGH  (){ 0x04 }
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 load_ref($) {
   my ($path) = @_;

   open my $fh, "<:raw:perlio", $path
      or die "$path: $!";
   local $/;

   thaw <$fh>
}

sub save_ref($$) {
   my ($ref, $path) = @_;

   open my $fh, ">:raw:perlio", "$path~"
      or die "$path~: $!";
   print $fh freeze $ref;
   close $fh;
   rename "$path~", $path
      or die "$path: $!";
}

# object as in "Object xxx", i.e. archetypes
sub normalize_object($) {
   my ($ob) = @_;

   # nuke outdated or never supported fields
   delete $ob->{$_} for qw(
      can_knockback can_parry can_impale can_cut can_dam_armour
      can_apply pass_thru can_pass_thru
   );

   # 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;
   }

   # convert outdated movement flags to new movement sets
   if (defined (my $v = delete $ob->{no_pass})) {
      $ob->{move_block} = $v ? MOVE_ALL : 0;
   }
   if (defined (my $v = delete $ob->{slow_move})) {
      $ob->{move_slow} |= MOVE_WALK;
      $ob->{move_slow_penalty} = $v;
   }
   if (defined (my $v = delete $ob->{walk_on})) {
      $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK
                          : $ob->{move_on} & ~MOVE_WALK;
   }
   if (defined (my $v = delete $ob->{walk_off})) {
      $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK
                           : $ob->{move_off} & ~MOVE_WALK;
   }
   if (defined (my $v = delete $ob->{fly_on})) {
      $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW
                          : $ob->{move_on} & ~MOVE_FLY_LOW;
   }
   if (defined (my $v = delete $ob->{fly_off})) {
      $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW
                           : $ob->{move_off} & ~MOVE_FLY_LOW;
   }
   if (defined (my $v = delete $ob->{flying})) {
      $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
                            : $ob->{move_type} & ~MOVE_FLY_LOW;
   }

   # convert idiotic event_xxx things into objects
   while (my ($event, $subtype) = each %EVENT_TYPE) {
      if (exists $ob->{"event_${event}_plugin"}) {
         push @{$ob->{inventory}}, {
            _name   => "event_$event",
            title   => delete $ob->{"event_${event}_plugin"},
            slaying => delete $ob->{"event_${event}"},
            name    => delete $ob->{"event_${event}_options"},
         };
      }
   }

   $ob
}

# arch as in "arch xxx", ie.. objects
sub normalize_arch($) {
   my ($ob) = @_;

   normalize_object $ob;

   my $arch = $ARCH{$ob->{_name}}
      or (warn "$ob->{_name}: no such archetype", return $ob);

   if ($arch->{type} == 22) { # map
      my %normalize = (
         "enter_x"         => "hp",
         "enter_y"         => "sp",
         "width"           => "x",
         "height"          => "y",
         "reset_timeout"   => "weight",
         "swap_time"       => "value",
         "difficulty"      => "level",
         "darkness"        => "invisible",
         "fixed_resettime" => "stand_still",
      );

      while (my ($k2, $k1) = each %normalize) {
         if (defined (my $v = delete $ob->{$k1})) {
            $ob->{$k2} = $v;
         }
      }
   } else {
      # if value matches archetype default, delete
      while (my ($k, $v) = each %$ob) {
         if (exists $arch->{$k} and $arch->{$k} eq $v) {
            next if $k eq "_name";
            delete $ob->{$k};
         }
      }
   }

   # a speciality for the editor
   if (exists $ob->{attack_movement}) {
      my $am = delete $ob->{attack_movement};
      $ob->{attack_movement_bits_0_3} = $am &  15;
      $ob->{attack_movement_bits_4_7} = $am & 240;
   }

   $ob
}

sub read_pak($) {
   my ($path) = @_;

   my %pak;

   open my $fh, "<:raw:perlio", $path
      or Carp::croak "$_[0]: $!";
   binmode $fh;
   while (<$fh>) {
      my ($type, $id, $len, $path) = split;
      $path =~ s/.*\///;
      read $fh, $pak{$path}, $len;
   }

   \%pak
}

sub read_arch($;$) {
   my ($path, $toplevel) = @_;

   my %arc;
   my ($more, $prev);

   open my $fh, "<:raw:perlio:utf8", $path
      or Carp::croak "$path: $!";

   binmode $fh;

   my $parse_block; $parse_block = sub {
      my %arc = @_;

      while (<$fh>) {
         s/\s+$//;
         if (/^end$/i) {
            last;
         } elsif (/^arch (\S+)$/i) {
            push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
         } elsif (/^lore$/i) {
            while (<$fh>) {
               last if /^endlore\s*$/i;
               $arc{lore} .= $_;
            }
         } elsif (/^msg$/i) {
            while (<$fh>) {
               last if /^endmsg\s*$/i;
               $arc{msg} .= $_;
            }
         } elsif (/^anim$/i) {
            while (<$fh>) {
               last if /^mina\s*$/i;
               chomp;
               push @{ $arc{anim} }, $_;
            }
         } elsif (/^(\S+)\s*(.*)$/) {
            $arc{lc $1} = $2;
         } elsif (/^\s*($|#)/) {
            #
         } else {
            warn "$path: unparsable line '$_' in arch $arc{_name}";
         }
      }

      \%arc
   };

   while (<$fh>) {
      s/\s+$//;
      if (/^more$/i) {
         $more = $prev;
      } elsif (/^object (\S+)$/i) {
         my $name = $1;
         my $arc = normalize_object $parse_block->(_name => $name);

         if ($more) {
            $more->{more} = $arc;
         } else {
            $arc{$name} = $arc;
         }
         $prev = $arc;
         $more = undef;
      } elsif (/^arch (\S+)$/i) {
         my $name = $1;
         my $arc = normalize_arch $parse_block->(_name => $name);

         if ($more) {
            $more->{more} = $arc;
         } else {
            push @{ $arc{arch} }, $arc;
         }
         $prev = $arc;
         $more = undef;
      } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
         if ($1 eq "lev_array") {
            while (<$fh>) {
               last if /^endplst\s*$/;
               push @{$toplevel->{lev_array}}, $_+0;
            }
         } else {
            $toplevel->{$1} = $2;
         }
      } elsif (/^\s*($|#)/) {
         #
      } else {
         die "$path: unparseable top-level line '$_'";
      }
   }

   undef $parse_block; # work around bug in perl not freeing $fh etc.

   \%arc
}

# put all archs into a hash with editor_face as it's key
# NOTE: the arrays in the hash values are references to 
# the archs from $ARCH
sub editor_archs {
   my %paths;

   for (keys %ARCH) {
      my $arch = $ARCH{$_};
      push @{$paths{$arch->{editor_folder}}}, $arch;
   }

   \%paths
}

=item ($minx, $miny, $maxx, $maxy) = arch_extents $arch

arch_extents determines the extents of the given arch's face(s), linked
faces and single faces are handled here it returns (minx, miny, maxx,
maxy)

=cut

sub arch_extents {
   my ($a) = @_;

   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;

   if ($face->{w} > 1 || $face->{h} > 1) { 
      # bigface
      return (0, 0, $face->{w} - 1, $face->{h} - 1);

   } elsif ($o->{more}) {
      # linked face
      my ($minx, $miny, $maxx, $maxy) = ($o->{x}, $o->{y}) x 2;

      for (; $o; $o = $o->{more}) {
         $minx = min $minx, $o->{x};
         $miny = min $miny, $o->{y};
         $maxx = max $maxx, $o->{x};
         $maxy = max $maxy, $o->{y};
      }

      return ($minx, $miny, $maxx, $maxy);

   } else {
      # single face
      return (0, 0, 0, 0);
   }
}

=item $type = arch_attr $arch

Returns a hashref describing the object and its attributes. It can contain
the following keys:

   name   the name, suitable for display purposes
   ignore
   attr
   desc
   use
   section => [name => \%attr, name => \%attr]
   import

=cut

sub arch_attr($) {
   my ($obj) = @_;

   require Crossfire::Data;

   my $root;
   my $attr = { };
   
   my $arch = $ARCH{ $obj->{_name} };
   my $type = $obj->{type} || $arch->{type};

   if ($type > 0) {
      $root = $Crossfire::Data::ATTR{$type};
   } else {
      my %a = (%$arch, %$obj);

      if ($a{is_floor} && !$a{alive}) {
         $root = $Crossfire::Data::TYPE{Floor};
      } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
         $root = $Crossfire::Data::TYPE{"Monster & NPC"};
      } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
         $root = $Crossfire::Data::TYPE{Wall};
      } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
         $root = $Crossfire::Data::TYPE{"Weak Wall"};
      } else {
         $root = $Crossfire::Data::TYPE{Misc};
      }
   }

   my @import = ($root);
   
   unshift @import, \%Crossfire::Data::DEFAULT_ATTR
      unless $type == 116;

   my (%ignore);
   my (@section_order, %section, @attr_order);

   while (my $type = shift @import) {
      push @import, @{$type->{import} || []};

      $attr->{$_} ||= $type->{$_}
         for qw(name desc use);

      for (@{$type->{ignore} || []}) {
         $ignore{$_}++ for ref $_ ? @$_ : $_;
      }

      for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
         my ($name, $attr) = @$_;
         push @section_order, $name;
         for (@$attr) {
            my ($k, $v) = @$_;
            push @attr_order, $k;
            $section{$name}{$k} ||= $v;
         }
      }
   }

   $attr->{section} = [
      map !exists $section{$_} ? () : do {
            my $attr = delete $section{$_};

            [
               $_,
               map exists $attr->{$_} && !$ignore{$_}
                      ? [$_ => delete $attr->{$_}] : (),
                   @attr_order
            ]
         },
         
         exists $section{$_} ? [$_ => delete $section{$_}] : (), 
         @section_order
   ];

   $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) = @_;

   my ($size, $mtime) = (stat $src)[7,9]
      or Carp::croak "$src: $!";

   if (-e $cache) {
      my $ref = eval { load_ref $cache };

      if ($ref->{version} == 1
          && $ref->{size} == $size
          && $ref->{mtime} == $mtime
          && eval { $load->($ref->{data}); 1 }) {
         return;
      }
   }

   my $ref = {
      version => 1,
      size    => $size,
      mtime   => $mtime,
      data    => $create->(),
   };

   $load->($ref->{data});

   save_ref $ref, $cache;
}

=item set_libdir $path

Sets the library directory to the given path
(default: $ENV{CROSSFIRE_LIBDIR}).

You have to (re-)load the archetypes and tilecache manually after steting
the library path.

=cut

sub set_libdir($) {
   $LIB = $_[0];
}

=item load_archetypes

(Re-)Load archetypes into %ARCH.

=cut

sub load_archetypes() {
   cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
      *ARCH = $_[0];
   }, sub {
      read_arch "$LIB/archetypes"
   };
}

=item load_tilecache

(Re-)Load %TILE and %FACE.

=cut

sub load_tilecache() {
   require Gtk2;

   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";

      my %cache;

      my $idx = 0;

      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,
         };
                  

         $idx += $tile->{w} * $tile->{h};
      }

      my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;

      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 % 64) * TILESIZE, TILESIZE * int $idx / 64);
            }
         }
      }

      $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);

      \%cache
   };
}

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

 Robin Redeker <elmex@ta-sa.org>
 http://www.ta-sa.org/

=cut

1
Revision:	1.65
Committed:	Wed May 3 19:34:31 2006 UTC (18 years ago) by root
Branch:	MAIN
Changes since 1.64:	+6 -0 lines
Log Message:	correctly read anim/mina
#	User	Rev	Content
1	elmex	1.1	=head1 NAME
2
3			Crossfire - Crossfire maphandling
4
5			=cut
6
7	root	1.4	package Crossfire;
8
9	elmex	1.3	our $VERSION = '0.1';
10	elmex	1.1
11			use strict;
12
13	root	1.7	use base 'Exporter';
14
15	root	1.13	use Carp ();
16	root	1.21	use File::Spec;
17	root	1.15	use List::Util qw(min max);
18	root	1.53	use Storable qw(freeze thaw);
19	elmex	1.1
20	root	1.50	our @EXPORT = qw(
21			read_pak read_arch ARCH TILESIZE $TILE FACE editor_archs arch_extents
22			);
23
24			our $LIB = $ENV{CROSSFIRE_LIBDIR};
25	root	1.7
26	root	1.50	our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire";
27
28			mkdir $VARDIR, 0777;
29	elmex	1.1
30	root	1.7	sub TILESIZE (){ 32 }
31	elmex	1.1
32	root	1.15	our %ARCH;
33			our %FACE;
34			our $TILE;
35	elmex	1.1
36	root	1.13	our %FIELD_MULTILINE = (
37	root	1.50	msg => "endmsg",
38			lore => "endlore",
39			maplore => "endmaplore",
40	root	1.13	);
41
42	root	1.58	# movement bit type, PITA
43			our %FIELD_MOVEMENT = map +($_ => undef),
44			qw(move_type move_block move_allow move_on move_off move_slow);
45
46	root	1.54	# same as in server save routine, to (hopefully) be compatible
47			# to the other editors.
48	root	1.56	our @FIELD_ORDER_MAP = (qw(
49			name swap_time reset_timeout fixed_resettime difficulty region
50			shopitems shopgreed shopmin shopmax shoprace
51			darkness width height enter_x enter_y msg maplore
52			unique template
53			outdoor temp pressure humid windspeed winddir sky nosmooth
54			tile_path_1 tile_path_2 tile_path_3 tile_path_4
55			));
56
57	root	1.54	our @FIELD_ORDER = (qw(
58	root	1.57	elevation
59
60	root	1.54	name name_pl custom_name title race
61			slaying skill msg lore other_arch face
62	root	1.56	#todo-events
63	root	1.54	animation is_animated
64	root	1.59	str dex con wis pow cha int
65	root	1.54	hp maxhp sp maxsp grace maxgrace
66			exp perm_exp expmul
67			food dam luck wc ac x y speed speed_left move_state attack_movement
68	root	1.59	nrof level direction type subtype attacktype
69	root	1.54
70			resist_physical resist_magic resist_fire resist_electricity
71			resist_cold resist_confusion resist_acid resist_drain
72			resist_weaponmagic resist_ghosthit resist_poison resist_slow
73			resist_paralyze resist_turn_undead resist_fear resist_cancellation
74			resist_deplete resist_death resist_chaos resist_counterspell
75			resist_godpower resist_holyword resist_blind resist_internal
76			resist_life_stealing resist_disease
77
78			path_attuned path_repelled path_denied material materialname
79			value carrying weight invisible state magic
80			last_heal last_sp last_grace last_eat
81			connected glow_radius randomitems npx_status npc_program
82			run_away pick_up container will_apply smoothlevel
83			current_weapon_script weapontype tooltype elevation client_type
84			item_power duration range
85			range_modifier duration_modifier dam_modifier gen_sp_armour
86			move_type move_block move_allow move_on move_off move_on move_slow move_slow_penalty
87
88			alive wiz was_wiz applied unpaid can_use_shield no_pick is_animated monster
89			friendly generator is_thrown auto_apply treasure player sold see_invisible
90			can_roll overlay_floor is_turnable is_used_up identified reflecting changing
91			splitting hitback startequip blocksview undead scared unaggressive
92			reflect_missile reflect_spell no_magic no_fix_player is_lightable tear_down
93			run_away pick_up unique no_drop can_cast_spell can_use_scroll can_use_range
94			can_use_bow can_use_armour can_use_weapon can_use_ring has_ready_range
95			has_ready_bow xrays is_floor lifesave no_strength sleep stand_still
96			random_move only_attack confused stealth cursed damned see_anywhere
97			known_magical known_cursed can_use_skill been_applied has_ready_scroll
98			can_use_rod can_use_horn make_invisible inv_locked is_wooded is_hilly
99			has_ready_skill has_ready_weapon no_skill_ident is_blind can_see_in_dark
100			is_cauldron is_dust no_steal one_hit berserk neutral no_attack no_damage
101			activate_on_push activate_on_release is_water use_content_on_gen is_buildable
102
103			body_range body_arm body_torso body_head body_neck body_skill
104			body_finger body_shoulder body_foot body_hand body_wrist body_waist
105			));
106	root	1.13
107	root	1.62	our %EVENT_TYPE = (
108			apply => 1,
109			attack => 2,
110			death => 3,
111			drop => 4,
112			pickup => 5,
113			say => 6,
114			stop => 7,
115			time => 8,
116			throw => 9,
117			trigger => 10,
118			close => 11,
119			timer => 12,
120			);
121
122	root	1.50	sub MOVE_WALK (){ 0x01 }
123			sub MOVE_FLY_LOW (){ 0x02 }
124			sub MOVE_FLY_HIGH (){ 0x04 }
125			sub MOVE_FLYING (){ 0x06 }
126			sub MOVE_SWIM (){ 0x08 }
127			sub MOVE_BOAT (){ 0x10 }
128	root	1.58	sub MOVE_KNOWN (){ 0x1f } # all of above
129			sub MOVE_ALLBIT (){ 0x10000 }
130			sub MOVE_ALL (){ 0x1001f } # very special value, more PITA
131	root	1.14
132	root	1.28	sub load_ref($) {
133			my ($path) = @_;
134
135	root	1.63	open my $fh, "<:raw:perlio", $path
136	root	1.31	or die "$path: $!";
137	root	1.28	local $/;
138	root	1.33
139	root	1.53	thaw <$fh>
140	root	1.28	}
141
142			sub save_ref($$) {
143			my ($ref, $path) = @_;
144
145	root	1.63	open my $fh, ">:raw:perlio", "$path~"
146	root	1.28	or die "$path~: $!";
147	root	1.53	print $fh freeze $ref;
148	root	1.28	close $fh;
149			rename "$path~", $path
150			or die "$path: $!";
151			}
152
153	root	1.62	# object as in "Object xxx", i.e. archetypes
154	root	1.52	sub normalize_object($) {
155	root	1.14	my ($ob) = @_;
156
157	root	1.62	# nuke outdated or never supported fields
158	root	1.50	delete $ob->{$_} for qw(
159			can_knockback can_parry can_impale can_cut can_dam_armour
160			can_apply pass_thru can_pass_thru
161			);
162	root	1.14
163	root	1.62	# convert movement strings to bitsets
164	root	1.58	for my $attr (keys %FIELD_MOVEMENT) {
165	root	1.50	next unless exists $ob->{$attr};
166	root	1.58
167			$ob->{$attr} = MOVE_ALL if $ob->{$attr} == 255; #d# compatibility
168
169	root	1.50	next if $ob->{$attr} =~ /^\d+$/;
170
171			my $flags = 0;
172
173			# assume list
174			for my $flag (map lc, split /\s+/, $ob->{$attr}) {
175			$flags \|= MOVE_WALK if $flag eq "walk";
176			$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
177			$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
178			$flags \|= MOVE_FLYING if $flag eq "flying";
179			$flags \|= MOVE_SWIM if $flag eq "swim";
180			$flags \|= MOVE_BOAT if $flag eq "boat";
181			$flags \|= MOVE_ALL if $flag eq "all";
182
183			$flags &= ~MOVE_WALK if $flag eq "-walk";
184			$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
185			$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
186			$flags &= ~MOVE_FLYING if $flag eq "-flying";
187			$flags &= ~MOVE_SWIM if $flag eq "-swim";
188			$flags &= ~MOVE_BOAT if $flag eq "-boat";
189			$flags &= ~MOVE_ALL if $flag eq "-all";
190			}
191
192			$ob->{$attr} = $flags;
193			}
194
195	root	1.62	# convert outdated movement flags to new movement sets
196	root	1.14	if (defined (my $v = delete $ob->{no_pass})) {
197			$ob->{move_block} = $v ? MOVE_ALL : 0;
198			}
199	root	1.50	if (defined (my $v = delete $ob->{slow_move})) {
200			$ob->{move_slow} \|= MOVE_WALK;
201			$ob->{move_slow_penalty} = $v;
202			}
203	root	1.14	if (defined (my $v = delete $ob->{walk_on})) {
204			$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
205			: $ob->{move_on} & ~MOVE_WALK;
206			}
207			if (defined (my $v = delete $ob->{walk_off})) {
208			$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
209			: $ob->{move_off} & ~MOVE_WALK;
210			}
211			if (defined (my $v = delete $ob->{fly_on})) {
212			$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
213			: $ob->{move_on} & ~MOVE_FLY_LOW;
214			}
215			if (defined (my $v = delete $ob->{fly_off})) {
216			$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
217			: $ob->{move_off} & ~MOVE_FLY_LOW;
218			}
219			if (defined (my $v = delete $ob->{flying})) {
220			$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
221			: $ob->{move_type} & ~MOVE_FLY_LOW;
222			}
223
224	root	1.62	# convert idiotic event_xxx things into objects
225			while (my ($event, $subtype) = each %EVENT_TYPE) {
226			if (exists $ob->{"event_${event}_plugin"}) {
227			push @{$ob->{inventory}}, {
228			_name => "event_$event",
229			title => delete $ob->{"event_${event}_plugin"},
230			slaying => delete $ob->{"event_${event}"},
231			name => delete $ob->{"event_${event}_options"},
232			};
233			}
234			}
235
236	root	1.52	$ob
237			}
238
239	root	1.62	# arch as in "arch xxx", ie.. objects
240	root	1.52	sub normalize_arch($) {
241			my ($ob) = @_;
242
243			normalize_object $ob;
244
245			my $arch = $ARCH{$ob->{_name}}
246			or (warn "$ob->{_name}: no such archetype", return $ob);
247
248			if ($arch->{type} == 22) { # map
249			my %normalize = (
250			"enter_x" => "hp",
251			"enter_y" => "sp",
252			"width" => "x",
253			"height" => "y",
254			"reset_timeout" => "weight",
255			"swap_time" => "value",
256			"difficulty" => "level",
257			"darkness" => "invisible",
258			"fixed_resettime" => "stand_still",
259			);
260
261			while (my ($k2, $k1) = each %normalize) {
262			if (defined (my $v = delete $ob->{$k1})) {
263			$ob->{$k2} = $v;
264			}
265			}
266			} else {
267			# if value matches archetype default, delete
268			while (my ($k, $v) = each %$ob) {
269			if (exists $arch->{$k} and $arch->{$k} eq $v) {
270			next if $k eq "_name";
271			delete $ob->{$k};
272			}
273	root	1.14	}
274			}
275
276	root	1.57	# a speciality for the editor
277			if (exists $ob->{attack_movement}) {
278			my $am = delete $ob->{attack_movement};
279			$ob->{attack_movement_bits_0_3} = $am & 15;
280			$ob->{attack_movement_bits_4_7} = $am & 240;
281			}
282
283	root	1.14	$ob
284			}
285	root	1.13
286	root	1.50	sub read_pak($) {
287			my ($path) = @_;
288
289			my %pak;
290	elmex	1.1
291	root	1.63	open my $fh, "<:raw:perlio", $path
292	root	1.50	or Carp::croak "$_[0]: $!";
293			binmode $fh;
294			while (<$fh>) {
295			my ($type, $id, $len, $path) = split;
296			$path =~ s/.*\///;
297			read $fh, $pak{$path}, $len;
298	elmex	1.1	}
299	root	1.50
300			\%pak
301	elmex	1.1	}
302
303	root	1.64	sub read_arch($;$) {
304			my ($path, $toplevel) = @_;
305	root	1.50
306			my %arc;
307			my ($more, $prev);
308
309	root	1.63	open my $fh, "<:raw:perlio:utf8", $path
310	root	1.50	or Carp::croak "$path: $!";
311
312			binmode $fh;
313	elmex	1.1
314	root	1.50	my $parse_block; $parse_block = sub {
315			my %arc = @_;
316	elmex	1.1
317			while (<$fh>) {
318			s/\s+$//;
319	root	1.50	if (/^end$/i) {
320			last;
321	root	1.55	} elsif (/^arch (\S+)$/i) {
322	root	1.50	push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
323	root	1.55	} elsif (/^lore$/i) {
324	root	1.50	while (<$fh>) {
325			last if /^endlore\s*$/i;
326			$arc{lore} .= $_;
327	elmex	1.1	}
328	root	1.55	} elsif (/^msg$/i) {
329	root	1.50	while (<$fh>) {
330			last if /^endmsg\s*$/i;
331			$arc{msg} .= $_;
332			}
333	root	1.65	} elsif (/^anim$/i) {
334			while (<$fh>) {
335			last if /^mina\s*$/i;
336			chomp;
337			push @{ $arc{anim} }, $_;
338			}
339	root	1.50	} elsif (/^(\S+)\s(.)$/) {
340			$arc{lc $1} = $2;
341	elmex	1.1	} elsif (/^\s*($\|#)/) {
342			#
343			} else {
344	root	1.50	warn "$path: unparsable line '$_' in arch $arc{_name}";
345	elmex	1.1	}
346			}
347
348	root	1.50	\%arc
349			};
350	elmex	1.2
351	root	1.50	while (<$fh>) {
352			s/\s+$//;
353			if (/^more$/i) {
354			$more = $prev;
355			} elsif (/^object (\S+)$/i) {
356			my $name = $1;
357	root	1.52	my $arc = normalize_object $parse_block->(_name => $name);
358	elmex	1.1
359	root	1.50	if ($more) {
360			$more->{more} = $arc;
361			} else {
362			$arc{$name} = $arc;
363			}
364			$prev = $arc;
365			$more = undef;
366			} elsif (/^arch (\S+)$/i) {
367	root	1.55	my $name = $1;
368	root	1.57	my $arc = normalize_arch $parse_block->(_name => $name);
369	root	1.55
370			if ($more) {
371			$more->{more} = $arc;
372			} else {
373			push @{ $arc{arch} }, $arc;
374			}
375			$prev = $arc;
376			$more = undef;
377	root	1.64	} elsif ($toplevel && /^(\S+)\s+(.*)$/) {
378			if ($1 eq "lev_array") {
379			while (<$fh>) {
380			last if /^endplst\s*$/;
381			push @{$toplevel->{lev_array}}, $_+0;
382			}
383			} else {
384			$toplevel->{$1} = $2;
385			}
386	root	1.50	} elsif (/^\s*($\|#)/) {
387			#
388			} else {
389	root	1.64	die "$path: unparseable top-level line '$_'";
390	root	1.50	}
391	elmex	1.2	}
392	root	1.50
393			undef $parse_block; # work around bug in perl not freeing $fh etc.
394
395			\%arc
396	elmex	1.1	}
397
398	elmex	1.10	# put all archs into a hash with editor_face as it's key
399			# NOTE: the arrays in the hash values are references to
400			# the archs from $ARCH
401			sub editor_archs {
402			my %paths;
403
404	root	1.15	for (keys %ARCH) {
405			my $arch = $ARCH{$_};
406	root	1.62	push @{$paths{$arch->{editor_folder}}}, $arch;
407	elmex	1.10	}
408
409	root	1.15	\%paths
410	elmex	1.10	}
411
412	root	1.17	=item ($minx, $miny, $maxx, $maxy) = arch_extents $arch
413
414			arch_extents determines the extents of the given arch's face(s), linked
415			faces and single faces are handled here it returns (minx, miny, maxx,
416			maxy)
417
418			=cut
419
420	root	1.15	sub arch_extents {
421	elmex	1.10	my ($a) = @_;
422
423	root	1.15	my $o = $ARCH{$a->{_name}}
424			or return;
425	elmex	1.10
426	root	1.45	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}
427	root	1.15	or (warn "no face data found for arch '$a->{_name}'"), return;
428	elmex	1.10
429	root	1.15	if ($face->{w} > 1 \|\| $face->{h} > 1) {
430			# bigface
431			return (0, 0, $face->{w} - 1, $face->{h} - 1);
432
433			} elsif ($o->{more}) {
434			# linked face
435			my ($minx, $miny, $maxx, $maxy) = ($o->{x}, $o->{y}) x 2;
436
437			for (; $o; $o = $o->{more}) {
438			$minx = min $minx, $o->{x};
439			$miny = min $miny, $o->{y};
440			$maxx = max $maxx, $o->{x};
441			$maxy = max $maxy, $o->{y};
442			}
443
444			return ($minx, $miny, $maxx, $maxy);
445	elmex	1.10
446			} else {
447			# single face
448	root	1.15	return (0, 0, 0, 0);
449	elmex	1.10	}
450			}
451
452	root	1.19	=item $type = arch_attr $arch
453	root	1.17
454			Returns a hashref describing the object and its attributes. It can contain
455			the following keys:
456
457			name the name, suitable for display purposes
458			ignore
459			attr
460			desc
461			use
462			section => [name => \%attr, name => \%attr]
463	root	1.19	import
464	root	1.17
465			=cut
466
467			sub arch_attr($) {
468	root	1.46	my ($obj) = @_;
469	root	1.17
470			require Crossfire::Data;
471
472	root	1.36	my $root;
473	root	1.49	my $attr = { };
474	root	1.46
475			my $arch = $ARCH{ $obj->{_name} };
476			my $type = $obj->{type} \|\| $arch->{type};
477	root	1.17
478	root	1.46	if ($type > 0) {
479			$root = $Crossfire::Data::ATTR{$type};
480	root	1.17	} else {
481	root	1.61	my %a = (%$arch, %$obj);
482	root	1.18
483	root	1.61	if ($a{is_floor} && !$a{alive}) {
484			$root = $Crossfire::Data::TYPE{Floor};
485			} elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
486			$root = $Crossfire::Data::TYPE{"Monster & NPC"};
487			} elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
488			$root = $Crossfire::Data::TYPE{Wall};
489			} elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
490			$root = $Crossfire::Data::TYPE{"Weak Wall"};
491			} else {
492			$root = $Crossfire::Data::TYPE{Misc};
493	root	1.18	}
494	root	1.17	}
495
496	root	1.47	my @import = ($root);
497
498			unshift @import, \%Crossfire::Data::DEFAULT_ATTR
499			unless $type == 116;
500
501	root	1.36	my (%ignore);
502			my (@section_order, %section, @attr_order);
503
504			while (my $type = shift @import) {
505			push @import, @{$type->{import} \|\| []};
506
507			$attr->{$_} \|\|= $type->{$_}
508			for qw(name desc use);
509
510			for (@{$type->{ignore} \|\| []}) {
511			$ignore{$_}++ for ref $_ ? @$_ : $_;
512			}
513
514	root	1.43	for ([general => ($type->{attr} \|\| [])], @{$type->{section} \|\| []}) {
515	root	1.36	my ($name, $attr) = @$_;
516			push @section_order, $name;
517	root	1.43	for (@$attr) {
518	root	1.36	my ($k, $v) = @$_;
519			push @attr_order, $k;
520			$section{$name}{$k} \|\|= $v;
521			}
522			}
523			}
524
525			$attr->{section} = [
526			map !exists $section{$_} ? () : do {
527			my $attr = delete $section{$_};
528
529			[
530			$_,
531	root	1.38	map exists $attr->{$_} && !$ignore{$_}
532			? [$_ => delete $attr->{$_}] : (),
533	root	1.36	@attr_order
534			]
535			},
536
537			exists $section{$_} ? [$_ => delete $section{$_}] : (),
538			@section_order
539			];
540
541			$attr
542	root	1.17	}
543
544	root	1.16	sub arch_edit_sections {
545			# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
546			# edit_type = 0;
547			# else if (edit_type != 0) {
548			# // all flags from 'check_type' must be unset in this arch because they get recalculated now
549			# edit_type &= ~check_type;
550			# }
551			#
552			# }
553			# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
554			# getAttributeValue("alive", defarch) == 1 &&
555			# (getAttributeValue("monster", defarch) == 1 \|\|
556			# getAttributeValue("generator", defarch) == 1)) {
557			# // Monster: monsters/npcs/generators
558			# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
559			# }
560			# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
561			# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
562			# // Walls
563			# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
564			# }
565			# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
566			# getAttributeValue("connected", defarch) != 0) {
567			# // Connected Objects
568			# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
569			# }
570			# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
571			# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
572			# // Exit: teleporter/exit/trapdoors
573			# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
574			# }
575			# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
576			# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
577			# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
578			# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
579			# arch_type == 124 \|\| arch_type == 130)) {
580			# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
581			# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
582			# }
583			# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
584			# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
585			# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
586			# // Door: door/special door/gates + keys
587			# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
588			# }
589			# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
590			# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
591			# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
592			# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
593			# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
594			# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
595			# arch_type == 122 \|\| arch_type == 3)) {
596			# // Equipment: weapons/armour/wands/rods
597			# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
598			# }
599			#
600			# return(edit_type);
601			#
602			#
603			}
604
605	root	1.50	sub cache_file($$&&) {
606			my ($src, $cache, $load, $create) = @_;
607	root	1.24
608	root	1.50	my ($size, $mtime) = (stat $src)[7,9]
609			or Carp::croak "$src: $!";
610
611			if (-e $cache) {
612			my $ref = eval { load_ref $cache };
613
614			if ($ref->{version} == 1
615			&& $ref->{size} == $size
616			&& $ref->{mtime} == $mtime
617			&& eval { $load->($ref->{data}); 1 }) {
618			return;
619			}
620			}
621
622			my $ref = {
623			version => 1,
624			size => $size,
625			mtime => $mtime,
626			data => $create->(),
627			};
628
629			$load->($ref->{data});
630
631			save_ref $ref, $cache;
632			}
633
634			=item set_libdir $path
635
636			Sets the library directory to the given path
637			(default: $ENV{CROSSFIRE_LIBDIR}).
638
639			You have to (re-)load the archetypes and tilecache manually after steting
640			the library path.
641
642			=cut
643
644			sub set_libdir($) {
645			$LIB = $_[0];
646	root	1.24	}
647
648	root	1.50	=item load_archetypes
649
650			(Re-)Load archetypes into %ARCH.
651
652			=cut
653
654			sub load_archetypes() {
655			cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
656			*ARCH = $_[0];
657			}, sub {
658			read_arch "$LIB/archetypes"
659			};
660			}
661	root	1.15
662	root	1.50	=item load_tilecache
663
664			(Re-)Load %TILE and %FACE.
665
666			=cut
667
668			sub load_tilecache() {
669			require Gtk2;
670
671			cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
672			$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
673			or die "$VARDIR/tilecache.png: $!";
674			*FACE = $_[0];
675			}, sub {
676			my $tile = read_pak "$LIB/crossfire.0";
677
678			my %cache;
679
680			my $idx = 0;
681
682			for my $name (sort keys %$tile) {
683	root	1.60	my $pb = new Gtk2::Gdk::PixbufLoader;
684			$pb->write ($tile->{$name});
685			$pb->close;
686			my $pb = $pb->get_pixbuf;
687	root	1.50
688			my $tile = $cache{$name} = {
689			pb => $pb,
690			idx => $idx,
691			w => int $pb->get_width / TILESIZE,
692			h => int $pb->get_height / TILESIZE,
693			};
694
695
696			$idx += $tile->{w} * $tile->{h};
697			}
698
699			my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
700
701			while (my ($name, $tile) = each %cache) {
702			my $tpb = delete $tile->{pb};
703			my $ofs = $tile->{idx};
704
705			for my $x (0 .. $tile->{w} - 1) {
706			for my $y (0 .. $tile->{h} - 1) {
707			my $idx = $ofs + $x + $y * $tile->{w};
708			$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
709			$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
710			}
711			}
712			}
713
714	root	1.60	$pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
715	root	1.50
716			\%cache
717			};
718			}
719	root	1.15
720	elmex	1.1	=head1 AUTHOR
721
722			Marc Lehmann <schmorp@schmorp.de>
723			http://home.schmorp.de/
724
725			Robin Redeker <elmex@ta-sa.org>
726			http://www.ta-sa.org/
727
728			=cut
729	root	1.4
730			1