--- deliantra/Deliantra/Deliantra.pm 2006/03/16 22:10:25 1.49 +++ deliantra/Deliantra/Deliantra.pm 2006/03/20 01:12:23 1.50 @@ -17,33 +17,38 @@ use List::Util qw(min max); use Storable; -our @EXPORT = - qw(read_pak read_arch %ARCH TILESIZE $TILE %FACE editor_archs arch_extents); +our @EXPORT = qw( + read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents +); + +our $LIB = $ENV{CROSSFIRE_LIBDIR}; -our $LIB = $ENV{CROSSFIRE_LIBDIR} - or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; +our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire"; + +mkdir $VARDIR, 0777; sub TILESIZE (){ 32 } -our $VARDIR; our %ARCH; our %FACE; our $TILE; our %FIELD_MULTILINE = ( - msg => "endmsg", - lore => "endlore", + msg => "endmsg", + lore => "endlore", + maplore => "endmaplore", ); # 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 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) = @_; @@ -74,7 +79,10 @@ 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); + 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 = ( @@ -96,9 +104,41 @@ } } + 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; @@ -131,110 +171,92 @@ $ob } -sub read_pak($;$) { - my ($path, $cache) = @_; +sub read_pak($) { + my ($path) = @_; - eval { - defined $cache - && -M $cache < -M $path - && load_ref $cache - } or do { - 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; - } - - save_ref \%pak, $cache - if defined $cache; - - \%pak + 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, $cache) = @_; - - eval { - defined $cache - && -M $cache < -M $path - && load_ref $cache - } or do { - 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}"; - } - } +sub read_arch($) { + my ($path) = @_; + + my %arc; + my ($more, $prev); + + open my $fh, "<", $path + or Carp::croak "$path: $!"; - \%arc - }; + binmode $fh; + + my $parse_block; $parse_block = sub { + my %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; + 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} .= $_; } - $prev = $arc; - $more = undef; - } elsif (/^arch (\S+)$/i) { - push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); + } elsif (/^msg$/) { + while (<$fh>) { + last if /^endmsg\s*$/i; + $arc{msg} .= $_; + } + } elsif (/^(\S+)\s*(.*)$/) { + $arc{lc $1} = $2; } elsif (/^\s*($|#)/) { # } else { - warn "$path: unparseable top-level line '$_'"; + warn "$path: unparsable line '$_' in arch $arc{_name}"; } } - undef $parse_block; # work around bug in perl not freeing $fh etc. + \%arc + }; - save_ref \%arc, $cache - if defined $cache; + while (<$fh>) { + s/\s+$//; + if (/^more$/i) { + $more = $prev; + } elsif (/^object (\S+)$/i) { + my $name = $1; + my $arc = $parse_block->(_name => $name); - \%arc + 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 @@ -446,18 +468,125 @@ # } -sub init($) { - my ($cachedir) = @_; +sub cache_file($$&&) { + my ($src, $cache, $load, $create) = @_; - return if %ARCH; + warn "<@_>\n";#d# - mkdir $cachedir, 0777; - *ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst"; + 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]; } -$VARDIR ||= $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire"; +=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" + }; +} -init $VARDIR; +=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