--- deliantra/Deliantra/Deliantra.pm 2006/02/23 15:10:08 1.32 +++ deliantra/Deliantra/Deliantra.pm 2006/03/27 17:38:18 1.61 @@ -15,54 +15,113 @@ use Carp (); use File::Spec; use List::Util qw(min max); +use Storable qw(freeze thaw); -#XXX: The map_* procedures scream for a map-object +our @EXPORT = qw( + read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents +); + +our $LIB = $ENV{CROSSFIRE_LIBDIR}; -our @EXPORT = - qw(read_pak read_arch %ARCH TILESIZE $TILE %FACE editor_archs arch_extents); +our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire"; -our $LIB = $ENV{CROSSFIRE_LIBDIR} - or Carp::croak "\$CROSSFIRE_LIBDIR must be set\n"; +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 } - -BEGIN { - if ($^O eq "MSWin32") { - eval "use FreezeThaw qw(freeze thaw)"; - } else { - eval "use Storable qw(freeze thaw)"; - } -} +# 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 +)); + +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) = @_; - die if $^O eq "MSWin32"; #d# - open my $fh, "<", $path or die "$path: $!"; binmode $fh; local $/; + thaw <$fh> } @@ -78,37 +137,52 @@ or die "$path: $!"; } -sub normalize_arch($) { +sub normalize_object($) { 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; - } + delete $ob->{$_} for qw( + can_knockback can_parry can_impale can_cut can_dam_armour + can_apply pass_thru can_pass_thru + ); + + 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; } 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; @@ -130,121 +204,150 @@ : $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 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, $cache) = @_; +sub read_pak($) { + my ($path) = @_; + + my %pak; - 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 + 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); - \%arc - }; + open my $fh, "<", $path + or Carp::croak "$path: $!"; + + 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; - } - $prev = $arc; - $more = undef; + if (/^end$/i) { + last; } elsif (/^arch (\S+)$/i) { - push @{ $arc{arch} }, normalize_arch $parse_block->(_name => $1); + 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 (/^(\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 = normalize_object $parse_block->(_name => $name); - \%arc + 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 (/^\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 @@ -275,7 +378,7 @@ my $o = $ARCH{$a->{_name}} or return; - my $face = $FACE{$a->{face} || $o->{face}} + 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) { @@ -317,32 +420,80 @@ =cut sub arch_attr($) { - my ($arch) = @_; + my ($obj) = @_; require Crossfire::Data; - my $attr; + my $root; + my $attr = { }; + + my $arch = $ARCH{ $obj->{_name} }; + my $type = $obj->{type} || $arch->{type}; - if ($arch->{type} > 0) { - $attr = $Crossfire::Data::ATTR{$arch->{type}+0}; + if ($type > 0) { + $root = $Crossfire::Data::ATTR{$type}; } else { - $attr = $Crossfire::Data::TYPE{Misc}; + my %a = (%$arch, %$obj); - type: - for (@Crossfire::Data::ATTR0) { - my $req = $_->{required} - or die "internal error: ATTR0 without 'required'"; - - while (my ($k, $v) = each %$req) { - next type - unless $arch->{$k} == $v; - } + 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); - $attr = $_; + 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 || \%Crossfire::Data::DEFAULT_ATTR; + $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 { @@ -406,18 +557,120 @@ # } -sub init($) { - my ($cachedir) = @_; +sub cache_file($$&&) { + my ($src, $cache, $load, $create) = @_; - return if %ARCH; + my ($size, $mtime) = (stat $src)[7,9] + or Carp::croak "$src: $!"; - mkdir $cachedir, 0777; - *ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst"; + 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; } -$VARDIR ||= $ENV{HOME} ? "$ENV{HOME}/.crossfire" : File::Spec->tmpdir . "/crossfire"; +=item set_libdir $path + +Sets the library directory to the given path +(default: $ENV{CROSSFIRE_LIBDIR}). -init $VARDIR; +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