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;

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

# not used yet, maybe alphabetical is ok
our @FIELD_ORDER = (qw(name name_pl));

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_ALL       (){ 0xff }

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

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

   Storable::thaw <$fh>
}

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

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

sub normalize_arch($) {
   my ($ob) = @_;

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

   delete $ob->{$_} for qw(
      can_knockback can_parry can_impale can_cut can_dam_armour
      can_apply pass_thru can_pass_thru
   );

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

   for my $attr (qw(move_type move_block move_allow move_on move_off move_slow)) {
      next unless exists $ob->{$attr};
      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;
   }

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

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

   $ob
}

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

   my %pak;

   open my $fh, "<", $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) = @_;

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

   open my $fh, "<", $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+)$/) {
            push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
         } elsif (/^lore$/) {
            while (<$fh>) {
               last if /^endlore\s*$/i;
               $arc{lore} .= $_;
            }
         } elsif (/^msg$/) {
            while (<$fh>) {
               last if /^endmsg\s*$/i;
               $arc{msg} .= $_;
            }
         } 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 = $parse_block->(_name => $name);

         if ($more) {
            $more->{more} = $arc;
         } else {
            $arc{$name} = $arc;
         }
         $prev = $arc;
         $more = undef;
      } elsif (/^arch (\S+)$/i) {
         push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1);
      } elsif (/^\s*($|#)/) {
         #
      } else {
         warn "$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 {
      $root = $Crossfire::Data::TYPE{Misc};

      type:
      for (@Crossfire::Data::ATTR0) {
         my $req = $_->{required}
            or die "internal error: ATTR0 without 'required'";

         keys %$req;
         while (my ($k, $v) = each %$req) {
            next type
               unless $obj->{$k} == $v || $arch->{$k} == $v;
         }

         $root = $_;
      }
   }

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

   warn "<@_>\n";#d#

   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 {
      require File::Temp;

      my $tile = read_pak "$LIB/crossfire.0";

      my %cache;

      my $idx = 0;

      for my $name (sort keys %$tile) {
         my ($fh, $filename) = File::Temp::tempfile ();
         print $fh $tile->{$name};
         close $fh;
         my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;
         unlink $filename;

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

      \%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.50
Committed:	Mon Mar 20 01:12:23 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.49:	+236 -107 lines
Log Message:	* empty log message *
#	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.34	use Storable;
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			# not used yet, maybe alphabetical is ok
43			our @FIELD_ORDER = (qw(name name_pl));
44
45	root	1.50	sub MOVE_WALK (){ 0x01 }
46			sub MOVE_FLY_LOW (){ 0x02 }
47			sub MOVE_FLY_HIGH (){ 0x04 }
48			sub MOVE_FLYING (){ 0x06 }
49			sub MOVE_SWIM (){ 0x08 }
50			sub MOVE_BOAT (){ 0x10 }
51			sub MOVE_ALL (){ 0xff }
52	root	1.14
53	root	1.28	sub load_ref($) {
54			my ($path) = @_;
55
56	root	1.31	open my $fh, "<", $path
57			or die "$path: $!";
58			binmode $fh;
59	root	1.28	local $/;
60	root	1.33
61	root	1.34	Storable::thaw <$fh>
62	root	1.28	}
63
64			sub save_ref($$) {
65			my ($ref, $path) = @_;
66
67	root	1.31	open my $fh, ">", "$path~"
68	root	1.28	or die "$path~: $!";
69	root	1.31	binmode $fh;
70	root	1.34	print $fh Storable::freeze $ref;
71	root	1.28	close $fh;
72			rename "$path~", $path
73			or die "$path: $!";
74			}
75
76	root	1.14	sub normalize_arch($) {
77			my ($ob) = @_;
78
79	root	1.15	my $arch = $ARCH{$ob->{_name}}
80	root	1.14	or (warn "$ob->{_name}: no such archetype", return $ob);
81
82	root	1.50	delete $ob->{$_} for qw(
83			can_knockback can_parry can_impale can_cut can_dam_armour
84			can_apply pass_thru can_pass_thru
85			);
86	root	1.14
87			if ($arch->{type} == 22) { # map
88			my %normalize = (
89			"enter_x" => "hp",
90			"enter_y" => "sp",
91			"width" => "x",
92			"height" => "y",
93			"reset_timeout" => "weight",
94			"swap_time" => "value",
95			"difficulty" => "level",
96			"darkness" => "invisible",
97			"fixed_resettime" => "stand_still",
98			);
99
100			while (my ($k2, $k1) = each %normalize) {
101			if (defined (my $v = delete $ob->{$k1})) {
102			$ob->{$k2} = $v;
103			}
104			}
105			}
106
107	root	1.50	for my $attr (qw(move_type move_block move_allow move_on move_off move_slow)) {
108			next unless exists $ob->{$attr};
109			next if $ob->{$attr} =~ /^\d+$/;
110
111			my $flags = 0;
112
113			# assume list
114			for my $flag (map lc, split /\s+/, $ob->{$attr}) {
115			$flags \|= MOVE_WALK if $flag eq "walk";
116			$flags \|= MOVE_FLY_LOW if $flag eq "fly_low";
117			$flags \|= MOVE_FLY_HIGH if $flag eq "fly_high";
118			$flags \|= MOVE_FLYING if $flag eq "flying";
119			$flags \|= MOVE_SWIM if $flag eq "swim";
120			$flags \|= MOVE_BOAT if $flag eq "boat";
121			$flags \|= MOVE_ALL if $flag eq "all";
122
123			$flags &= ~MOVE_WALK if $flag eq "-walk";
124			$flags &= ~MOVE_FLY_LOW if $flag eq "-fly_low";
125			$flags &= ~MOVE_FLY_HIGH if $flag eq "-fly_high";
126			$flags &= ~MOVE_FLYING if $flag eq "-flying";
127			$flags &= ~MOVE_SWIM if $flag eq "-swim";
128			$flags &= ~MOVE_BOAT if $flag eq "-boat";
129			$flags &= ~MOVE_ALL if $flag eq "-all";
130			}
131
132			$ob->{$attr} = $flags;
133			}
134
135	root	1.14	if (defined (my $v = delete $ob->{no_pass})) {
136			$ob->{move_block} = $v ? MOVE_ALL : 0;
137			}
138	root	1.50	if (defined (my $v = delete $ob->{slow_move})) {
139			$ob->{move_slow} \|= MOVE_WALK;
140			$ob->{move_slow_penalty} = $v;
141			}
142	root	1.14	if (defined (my $v = delete $ob->{walk_on})) {
143			$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_WALK
144			: $ob->{move_on} & ~MOVE_WALK;
145			}
146			if (defined (my $v = delete $ob->{walk_off})) {
147			$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_WALK
148			: $ob->{move_off} & ~MOVE_WALK;
149			}
150			if (defined (my $v = delete $ob->{fly_on})) {
151			$ob->{move_on} = $v ? $ob->{move_on} \| MOVE_FLY_LOW
152			: $ob->{move_on} & ~MOVE_FLY_LOW;
153			}
154			if (defined (my $v = delete $ob->{fly_off})) {
155			$ob->{move_off} = $v ? $ob->{move_off} \| MOVE_FLY_LOW
156			: $ob->{move_off} & ~MOVE_FLY_LOW;
157			}
158			if (defined (my $v = delete $ob->{flying})) {
159			$ob->{move_type} = $v ? $ob->{move_type} \| MOVE_FLY_LOW
160			: $ob->{move_type} & ~MOVE_FLY_LOW;
161			}
162
163			# if value matches archetype default, delete
164			while (my ($k, $v) = each %$ob) {
165			if (exists $arch->{$k} and $arch->{$k} eq $v) {
166	root	1.15	next if $k eq "_name";
167	root	1.14	delete $ob->{$k};
168			}
169			}
170
171			$ob
172			}
173	root	1.13
174	root	1.50	sub read_pak($) {
175			my ($path) = @_;
176
177			my %pak;
178	elmex	1.1
179	root	1.50	open my $fh, "<", $path
180			or Carp::croak "$_[0]: $!";
181			binmode $fh;
182			while (<$fh>) {
183			my ($type, $id, $len, $path) = split;
184			$path =~ s/.*\///;
185			read $fh, $pak{$path}, $len;
186	elmex	1.1	}
187	root	1.50
188			\%pak
189	elmex	1.1	}
190
191	root	1.50	sub read_arch($) {
192			my ($path) = @_;
193
194			my %arc;
195			my ($more, $prev);
196
197			open my $fh, "<", $path
198			or Carp::croak "$path: $!";
199
200			binmode $fh;
201	elmex	1.1
202	root	1.50	my $parse_block; $parse_block = sub {
203			my %arc = @_;
204	elmex	1.1
205			while (<$fh>) {
206			s/\s+$//;
207	root	1.50	if (/^end$/i) {
208			last;
209			} elsif (/^arch (\S+)$/) {
210			push @{ $arc{inventory} }, normalize_arch $parse_block->(_name => $1);
211			} elsif (/^lore$/) {
212			while (<$fh>) {
213			last if /^endlore\s*$/i;
214			$arc{lore} .= $_;
215	elmex	1.1	}
216	root	1.50	} elsif (/^msg$/) {
217			while (<$fh>) {
218			last if /^endmsg\s*$/i;
219			$arc{msg} .= $_;
220			}
221			} elsif (/^(\S+)\s(.)$/) {
222			$arc{lc $1} = $2;
223	elmex	1.1	} elsif (/^\s*($\|#)/) {
224			#
225			} else {
226	root	1.50	warn "$path: unparsable line '$_' in arch $arc{_name}";
227	elmex	1.1	}
228			}
229
230	root	1.50	\%arc
231			};
232	elmex	1.2
233	root	1.50	while (<$fh>) {
234			s/\s+$//;
235			if (/^more$/i) {
236			$more = $prev;
237			} elsif (/^object (\S+)$/i) {
238			my $name = $1;
239			my $arc = $parse_block->(_name => $name);
240	elmex	1.1
241	root	1.50	if ($more) {
242			$more->{more} = $arc;
243			} else {
244			$arc{$name} = $arc;
245			}
246			$prev = $arc;
247			$more = undef;
248			} elsif (/^arch (\S+)$/i) {
249			push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1);
250			} elsif (/^\s*($\|#)/) {
251			#
252			} else {
253			warn "$path: unparseable top-level line '$_'";
254			}
255	elmex	1.2	}
256	root	1.50
257			undef $parse_block; # work around bug in perl not freeing $fh etc.
258
259			\%arc
260	elmex	1.1	}
261
262	elmex	1.10	# put all archs into a hash with editor_face as it's key
263			# NOTE: the arrays in the hash values are references to
264			# the archs from $ARCH
265			sub editor_archs {
266			my %paths;
267
268	root	1.15	for (keys %ARCH) {
269			my $arch = $ARCH{$_};
270	elmex	1.10	push @{$paths{$arch->{editor_folder}}}, \$arch;
271			}
272
273	root	1.15	\%paths
274	elmex	1.10	}
275
276	root	1.17	=item ($minx, $miny, $maxx, $maxy) = arch_extents $arch
277
278			arch_extents determines the extents of the given arch's face(s), linked
279			faces and single faces are handled here it returns (minx, miny, maxx,
280			maxy)
281
282			=cut
283
284	root	1.15	sub arch_extents {
285	elmex	1.10	my ($a) = @_;
286
287	root	1.15	my $o = $ARCH{$a->{_name}}
288			or return;
289	elmex	1.10
290	root	1.45	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}
291	root	1.15	or (warn "no face data found for arch '$a->{_name}'"), return;
292	elmex	1.10
293	root	1.15	if ($face->{w} > 1 \|\| $face->{h} > 1) {
294			# bigface
295			return (0, 0, $face->{w} - 1, $face->{h} - 1);
296
297			} elsif ($o->{more}) {
298			# linked face
299			my ($minx, $miny, $maxx, $maxy) = ($o->{x}, $o->{y}) x 2;
300
301			for (; $o; $o = $o->{more}) {
302			$minx = min $minx, $o->{x};
303			$miny = min $miny, $o->{y};
304			$maxx = max $maxx, $o->{x};
305			$maxy = max $maxy, $o->{y};
306			}
307
308			return ($minx, $miny, $maxx, $maxy);
309	elmex	1.10
310			} else {
311			# single face
312	root	1.15	return (0, 0, 0, 0);
313	elmex	1.10	}
314			}
315
316	root	1.19	=item $type = arch_attr $arch
317	root	1.17
318			Returns a hashref describing the object and its attributes. It can contain
319			the following keys:
320
321			name the name, suitable for display purposes
322			ignore
323			attr
324			desc
325			use
326			section => [name => \%attr, name => \%attr]
327	root	1.19	import
328	root	1.17
329			=cut
330
331			sub arch_attr($) {
332	root	1.46	my ($obj) = @_;
333	root	1.17
334			require Crossfire::Data;
335
336	root	1.36	my $root;
337	root	1.49	my $attr = { };
338	root	1.46
339			my $arch = $ARCH{ $obj->{_name} };
340			my $type = $obj->{type} \|\| $arch->{type};
341	root	1.17
342	root	1.46	if ($type > 0) {
343			$root = $Crossfire::Data::ATTR{$type};
344	root	1.17	} else {
345	root	1.36	$root = $Crossfire::Data::TYPE{Misc};
346	root	1.18
347			type:
348			for (@Crossfire::Data::ATTR0) {
349			my $req = $_->{required}
350			or die "internal error: ATTR0 without 'required'";
351
352	root	1.35	keys %$req;
353	root	1.18	while (my ($k, $v) = each %$req) {
354			next type
355	root	1.48	unless $obj->{$k} == $v \|\| $arch->{$k} == $v;
356	root	1.18	}
357
358	root	1.36	$root = $_;
359	root	1.18	}
360	root	1.17	}
361
362	root	1.47	my @import = ($root);
363
364			unshift @import, \%Crossfire::Data::DEFAULT_ATTR
365			unless $type == 116;
366
367	root	1.36	my (%ignore);
368			my (@section_order, %section, @attr_order);
369
370			while (my $type = shift @import) {
371			push @import, @{$type->{import} \|\| []};
372
373			$attr->{$_} \|\|= $type->{$_}
374			for qw(name desc use);
375
376			for (@{$type->{ignore} \|\| []}) {
377			$ignore{$_}++ for ref $_ ? @$_ : $_;
378			}
379
380	root	1.43	for ([general => ($type->{attr} \|\| [])], @{$type->{section} \|\| []}) {
381	root	1.36	my ($name, $attr) = @$_;
382			push @section_order, $name;
383	root	1.43	for (@$attr) {
384	root	1.36	my ($k, $v) = @$_;
385			push @attr_order, $k;
386			$section{$name}{$k} \|\|= $v;
387			}
388			}
389			}
390
391			$attr->{section} = [
392			map !exists $section{$_} ? () : do {
393			my $attr = delete $section{$_};
394
395			[
396			$_,
397	root	1.38	map exists $attr->{$_} && !$ignore{$_}
398			? [$_ => delete $attr->{$_}] : (),
399	root	1.36	@attr_order
400			]
401			},
402
403			exists $section{$_} ? [$_ => delete $section{$_}] : (),
404			@section_order
405			];
406
407			$attr
408	root	1.17	}
409
410	root	1.16	sub arch_edit_sections {
411			# if (edit_type == IGUIConstants.TILE_EDIT_NONE)
412			# edit_type = 0;
413			# else if (edit_type != 0) {
414			# // all flags from 'check_type' must be unset in this arch because they get recalculated now
415			# edit_type &= ~check_type;
416			# }
417			#
418			# }
419			# if ((check_type & IGUIConstants.TILE_EDIT_MONSTER) != 0 &&
420			# getAttributeValue("alive", defarch) == 1 &&
421			# (getAttributeValue("monster", defarch) == 1 \|\|
422			# getAttributeValue("generator", defarch) == 1)) {
423			# // Monster: monsters/npcs/generators
424			# edit_type \|= IGUIConstants.TILE_EDIT_MONSTER;
425			# }
426			# if ((check_type & IGUIConstants.TILE_EDIT_WALL) != 0 &&
427			# arch_type == 0 && getAttributeValue("no_pass", defarch) == 1) {
428			# // Walls
429			# edit_type \|= IGUIConstants.TILE_EDIT_WALL;
430			# }
431			# if ((check_type & IGUIConstants.TILE_EDIT_CONNECTED) != 0 &&
432			# getAttributeValue("connected", defarch) != 0) {
433			# // Connected Objects
434			# edit_type \|= IGUIConstants.TILE_EDIT_CONNECTED;
435			# }
436			# if ((check_type & IGUIConstants.TILE_EDIT_EXIT) != 0 &&
437			# arch_type == 66 \|\| arch_type == 41 \|\| arch_type == 95) {
438			# // Exit: teleporter/exit/trapdoors
439			# edit_type \|= IGUIConstants.TILE_EDIT_EXIT;
440			# }
441			# if ((check_type & IGUIConstants.TILE_EDIT_TREASURE) != 0 &&
442			# getAttributeValue("no_pick", defarch) == 0 && (arch_type == 4 \|\|
443			# arch_type == 5 \|\| arch_type == 36 \|\| arch_type == 60 \|\|
444			# arch_type == 85 \|\| arch_type == 111 \|\| arch_type == 123 \|\|
445			# arch_type == 124 \|\| arch_type == 130)) {
446			# // Treasure: randomtreasure/money/gems/potions/spellbooks/scrolls
447			# edit_type \|= IGUIConstants.TILE_EDIT_TREASURE;
448			# }
449			# if ((check_type & IGUIConstants.TILE_EDIT_DOOR) != 0 &&
450			# arch_type == 20 \|\| arch_type == 23 \|\| arch_type == 26 \|\|
451			# arch_type == 91 \|\| arch_type == 21 \|\| arch_type == 24) {
452			# // Door: door/special door/gates + keys
453			# edit_type \|= IGUIConstants.TILE_EDIT_DOOR;
454			# }
455			# if ((check_type & IGUIConstants.TILE_EDIT_EQUIP) != 0 &&
456			# getAttributeValue("no_pick", defarch) == 0 && ((arch_type >= 13 &&
457			# arch_type <= 16) \|\| arch_type == 33 \|\| arch_type == 34 \|\|
458			# arch_type == 35 \|\| arch_type == 39 \|\| arch_type == 70 \|\|
459			# arch_type == 87 \|\| arch_type == 99 \|\| arch_type == 100 \|\|
460			# arch_type == 104 \|\| arch_type == 109 \|\| arch_type == 113 \|\|
461			# arch_type == 122 \|\| arch_type == 3)) {
462			# // Equipment: weapons/armour/wands/rods
463			# edit_type \|= IGUIConstants.TILE_EDIT_EQUIP;
464			# }
465			#
466			# return(edit_type);
467			#
468			#
469			}
470
471	root	1.50	sub cache_file($$&&) {
472			my ($src, $cache, $load, $create) = @_;
473	root	1.24
474	root	1.50	warn "<@_>\n";#d#
475	root	1.24
476	root	1.50	my ($size, $mtime) = (stat $src)[7,9]
477			or Carp::croak "$src: $!";
478
479			if (-e $cache) {
480			my $ref = eval { load_ref $cache };
481
482			if ($ref->{version} == 1
483			&& $ref->{size} == $size
484			&& $ref->{mtime} == $mtime
485			&& eval { $load->($ref->{data}); 1 }) {
486			return;
487			}
488			}
489
490			my $ref = {
491			version => 1,
492			size => $size,
493			mtime => $mtime,
494			data => $create->(),
495			};
496
497			$load->($ref->{data});
498
499			save_ref $ref, $cache;
500			}
501
502			=item set_libdir $path
503
504			Sets the library directory to the given path
505			(default: $ENV{CROSSFIRE_LIBDIR}).
506
507			You have to (re-)load the archetypes and tilecache manually after steting
508			the library path.
509
510			=cut
511
512			sub set_libdir($) {
513			$LIB = $_[0];
514	root	1.24	}
515
516	root	1.50	=item load_archetypes
517
518			(Re-)Load archetypes into %ARCH.
519
520			=cut
521
522			sub load_archetypes() {
523			cache_file "$LIB/archetypes", "$VARDIR/archetypes.pst", sub {
524			*ARCH = $_[0];
525			}, sub {
526			read_arch "$LIB/archetypes"
527			};
528			}
529	root	1.15
530	root	1.50	=item load_tilecache
531
532			(Re-)Load %TILE and %FACE.
533
534			=cut
535
536			sub load_tilecache() {
537			require Gtk2;
538
539			cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub {
540			$TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
541			or die "$VARDIR/tilecache.png: $!";
542			*FACE = $_[0];
543			}, sub {
544			require File::Temp;
545
546			my $tile = read_pak "$LIB/crossfire.0";
547
548			my %cache;
549
550			my $idx = 0;
551
552			for my $name (sort keys %$tile) {
553			my ($fh, $filename) = File::Temp::tempfile ();
554			print $fh $tile->{$name};
555			close $fh;
556			my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;
557			unlink $filename;
558
559			my $tile = $cache{$name} = {
560			pb => $pb,
561			idx => $idx,
562			w => int $pb->get_width / TILESIZE,
563			h => int $pb->get_height / TILESIZE,
564			};
565
566
567			$idx += $tile->{w} * $tile->{h};
568			}
569
570			my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
571
572			while (my ($name, $tile) = each %cache) {
573			my $tpb = delete $tile->{pb};
574			my $ofs = $tile->{idx};
575
576			for my $x (0 .. $tile->{w} - 1) {
577			for my $y (0 .. $tile->{h} - 1) {
578			my $idx = $ofs + $x + $y * $tile->{w};
579			$tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
580			$pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
581			}
582			}
583			}
584
585			$pb->save ("$VARDIR/tilecache.png", "png");
586
587			\%cache
588			};
589			}
590	root	1.15
591	elmex	1.1	=head1 AUTHOR
592
593			Marc Lehmann <schmorp@schmorp.de>
594			http://home.schmorp.de/
595
596			Robin Redeker <elmex@ta-sa.org>
597			http://www.ta-sa.org/
598
599			=cut
600	root	1.4
601			1