=head1 NAME Crossfire - Crossfire maphandling =cut package Crossfire; our $VERSION = '0.1'; use strict; use base 'Exporter'; use Carp (); use Storable; #XXX: The map_* procedures scream for a map-object our @EXPORT = qw(read_pak read_arch $ARCH TILESIZE editor_archs arch_extends map_get_tile_stack map_push_tile_stack map_pop_tile_stack ); our $LIB = $ENV{CROSSFIRE_LIBDIR} or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; sub TILESIZE (){ 32 } our $ARCH; our %FIELD_MULTILINE = ( msg => "endmsg", lore => "endlore", ); # not used yet, maybe alphabetical is ok our @FIELD_ORDER = (qw(name name_pl)); sub MOVE_WALK (){ 0x1 } sub MOVE_FLY_LOW (){ 0x2 } sub MOVE_FLY_HIGH (){ 0x4 } sub MOVE_FLYING (){ 0x6 } sub MOVE_SWIM (){ 0x8 } sub MOVE_ALL (){ 0xf } 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); 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; } } } if (defined (my $v = delete $ob->{no_pass})) { $ob->{move_block} = $v ? MOVE_ALL : 0; } 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) { delete $ob->{$k}; } } $ob } sub read_pak($;$) { my ($path, $cache) = @_; eval { defined $cache && -M $cache < -M $path && Storable::retrieve $cache } or do { my %pak; open my $fh, "<:raw", $path or Carp::croak "$_[0]: $!"; while (<$fh>) { my ($type, $id, $len, $path) = split; $path =~ s/.*\///; read $fh, $pak{$path}, $len; } Storable::nstore \%pak, $cache if defined $cache; \%pak } } sub read_arch($;$) { my ($path, $cache) = @_; eval { defined $cache && -M $cache < -M $path && Storable::retrieve $cache } or do { my %arc; my ($more, $prev); open my $fh, "<:raw", $path or Carp::croak "$path: $!"; 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. Storable::nstore \%arc, $cache if defined $cache; \%arc } } # returns the arch/object stack from a tile on a map sub map_get_tile_stack { my ($map, $x, $y) = @_; my $as; if ($x > 0 || $x < $map->{width} || $y > 0 || $y < $map->{height}) { $as = $map->{map}{map}[$x][$y] || []; } return $as; } # pop the topmost arch/object from the stack of a tile on a map sub map_pop_tile_stack { my ($map, $x, $y) = @_; if ($x > 0 || $x < $map->{width} || $y > 0 || $y < $map->{height}) { pop @{$map->{map}{map}[$x][$y]}; } } # pushes the arch/object on the stack of a tile on a map sub map_push_tile_stack { my ($map, $x, $y, $arch) = @_; if ($x > 0 || $x < $map->{width} || $y > 0 || $y < $map->{height}) { push @{$map->{map}{map}[$x][$y]}, $arch; } } # 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; } return \%paths; } # arch_extends determines how the arch looks like on the map, # bigfaces, linked faces and single faces are handled here # it returns (, , , ) # NOTE: non rectangular linked faces are not considered sub arch_extends { my ($a) = @_; my $TC = \%Crossfire::Tilecache::TILECACHE; my $facename = $a->{face} || $ARCH->{$a->{_name}}->{face} or return (); my $tile = $TC->{$facename} or (warn "no gfx found for arch '$facename' in arch_size ()"), return; if ($tile->{w} > 1 || $tile->{h} > 1) { # bigfaces return (0, 0, $tile->{w}, $tile->{h}); } elsif ($a->{more}) { # linked faces my ($miw, $mih, $maw, $mah) = (0, 0, 0, 0); do { $miw > (0 + $a->{x}) and $miw = $a->{x}; $mih > (0 + $a->{y}) and $mih = $a->{y}; $maw < (0 + $a->{x}) and $maw = $a->{x}; $mah < (0 + $a->{y}) and $mah = $a->{y}; } while $a = $a->{more}; return ($miw, $mih, ($maw - $miw) + 1, ($mah - $mih) + 1) } else { # single face return (0, 0, 1, 1); } } sub init($) { my ($cachedir) = @_; $ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst"; } =head1 AUTHOR Marc Lehmann http://home.schmorp.de/ Robin Redeker http://www.ta-sa.org/ =cut 1