=head1 NAME Crossfire - Crossfire maphandling =cut package Crossfire; our $VERSION = '0.1'; use strict; use base 'Exporter'; use Storable; our @EXPORT = qw(read_pak read_arch arch2map $ARCH TILESIZE editor_archs arch2pickmap arch_extends); our $LIB = $ENV{CROSSFIRE_LIBDIR} or die "\$CROSSFIRE_LIBDIR must be set\n"; sub TILESIZE (){ 32 } our $ARCH; 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 die "$_[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 die "$path: $!"; my $parse_block; $parse_block = sub { my %arc = @_; while (<$fh>) { s/\s+$//; if (/^end$/i) { last; } elsif (/^arch (\S+)$/) { push @{ $arc{inventory} }, $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} }, $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 } } # 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); } } # arch2pickmap forms a list of archs to a pickmap sub arch2pickmap { my ($archs, $w) = @_; # sort archs alphabetiacally my $archs = [ sort { ${$a}->{_name} cmp ${$b}->{_name} } @$archs ]; $w ||= 10; # default width my $num = @$archs; my $map = { }; # overall placement coords my $x = 0; my $y = 0; my ($maxh, $maxw) = (0, 0); # maximum sizes, to set map width/height later my $drawn_archs = 1; # line-break counter my $max_line_height = 1; for (my $i = 0; $i < $num; $i++) { defined ${$archs->[$i]}->{face} or next; # check whether this tile was already written (see below at (b)) unless (defined $map->{map}[$x][$y]) { my ($xoffs, $yoffs, $arch_w, $arch_h) = arch_extends (${$archs->[$i]}); # these are special placement coords, for chained faces which # have a special placement offset my ($place_x, $place_y) = ($x, $y); $xoffs < 0 and $place_x += -$xoffs; $yoffs < 0 and $place_y += -$yoffs; # iterate over the tiles this arch takes # NOTE: Chained archs are maybe not a rectangle, but i don't care # much for that on pickmaps for (my $xi = 0; $xi < $arch_w; $xi++) { for (my $yi = 0; $yi < $arch_h; $yi++) { my ($lx, $ly) = ($x + $xi, $y + $yi); if ($lx == $place_x and $ly == $place_y) { push @{$map->{map}[$place_x][$place_y]}, my $a = ${$archs->[$i]}; } else { # (b): here we set occupied tiles, but without the arch $map->{map}[$lx][$ly] = []; } } } $drawn_archs++; $x += $arch_w - 1; $max_line_height < $arch_h and $max_line_height = $arch_h; } else { $i--; } $x++; if ($x > $w) { $y += $max_line_height; $max_line_height = 1; $x = 0; } $maxw < ($x + 1) and $maxw = $x + 1; $maxh < ($y + 1) and $maxh = $y + 1; } $map->{height} = $maxh; $map->{width} = $maxw; return $map; } sub arch2map($;$) { my ($mapa) = @_; my %meta; my ($mapx, $mapy); my $map; for (@{ $mapa->{arch} }) { my ($x, $y) = (delete $_->{x}, delete $_->{y}); if ($_->{_name} eq "map") { $meta{info} = $_; $mapx = $_->{width} || $x; $mapy = $_->{height} || $y; } else { push @{ $map->[$x][$y] }, $_; # arch map is unreliable w.r.t. width and height $mapx = $x + 1 if $mapx <= $x; $mapy = $y + 1 if $mapy <= $y; #$mapx = $a->{x} + 1, warn "$mapname: arch '$a->{_name}' outside map width at ($a->{x}|$a->{y})\n" if $mapx <= $a->{x}; #$mapy = $a->{y} + 1, warn "$mapname: arch '$a->{_name}' outside map height at ($a->{x}|$a->{y})\n" if $mapy <= $a->{y}; } } $meta{width} = $mapx; $meta{height} = $mapy; $meta{map} = $map; \%meta } 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