[ViewVC] Diff of: cvs/deliantra/Deliantra/Deliantra.pm

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.56 by root, Thu Mar 23 07:33:16 2006 UTC vs.
Revision 1.64 by root, Sun Apr 2 20:17:23 2006 UTC

 our %FIELD_MULTILINE = (
    msg     => "endmsg",
    lore    => "endlore",
    maplore => "endmaplore",
 );
+# 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
    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
+   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
+   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
    body_range body_arm body_torso body_head body_neck body_skill
    body_finger body_shoulder body_foot body_hand body_wrist body_waist
 ));
+our %EVENT_TYPE = (
+   apply   =>  1,
+   attack  =>  2,
+   death   =>  3,
+   drop    =>  4,
+   pickup  =>  5,
+   say     =>  6,
+   stop    =>  7,
+   time    =>  8,
+   throw   =>  9,
+   trigger => 10,
+   close   => 11,
+   timer   => 12,
+);
 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_ALL       (){ 0xff }
+sub MOVE_ALLBIT    (){ 0x10000 }
+sub MOVE_ALL       (){ 0x1001f } # very special value, more PITA
 sub load_ref($) {
    my ($path) = @_;
-   open my $fh, "<", $path
+   open my $fh, "<:raw:perlio", $path
       or die "$path: $!";
-   binmode $fh;
    local $/;
    thaw <$fh>
 }
 sub save_ref($$) {
    my ($ref, $path) = @_;
-   open my $fh, ">", "$path~"
+   open my $fh, ">:raw:perlio", "$path~"
       or die "$path~: $!";
-   binmode $fh;
    print $fh freeze $ref;
    close $fh;
    rename "$path~", $path
       or die "$path: $!";
 }
+# object as in "Object xxx", i.e. archetypes
 sub normalize_object($) {
    my ($ob) = @_;
+   # nuke outdated or never supported fields
    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 (qw(move_type move_block move_allow move_on move_off move_slow)) {
+   # convert movement strings to bitsets
+   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
       }
       $ob->{$attr} = $flags;
    }
+   # convert outdated movement flags to new movement sets
    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;
    if (defined (my $v = delete $ob->{flying})) {
       $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW
                             : $ob->{move_type} & ~MOVE_FLY_LOW;
    }
+   # convert idiotic event_xxx things into objects
+   while (my ($event, $subtype) = each %EVENT_TYPE) {
+      if (exists $ob->{"event_${event}_plugin"}) {
+         push @{$ob->{inventory}}, {
+            _name   => "event_$event",
+            title   => delete $ob->{"event_${event}_plugin"},
+            slaying => delete $ob->{"event_${event}"},
+            name    => delete $ob->{"event_${event}_options"},
+         };
+      }
+   }
    $ob
 }
+# arch as in "arch xxx", ie.. objects
 sub normalize_arch($) {
    my ($ob) = @_;
    normalize_object $ob;
             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) = @_;
    my %pak;
-   open my $fh, "<", $path
+   open my $fh, "<:raw:perlio", $path
       or Carp::croak "$_[0]: $!";
    binmode $fh;
    while (<$fh>) {
       my ($type, $id, $len, $path) = split;
       $path =~ s/.*\///;
    }
    \%pak
 }
-sub read_arch($) {
+sub read_arch($;$) {
-   my ($path) = @_;
+   my ($path, $toplevel) = @_;
    my %arc;
    my ($more, $prev);
-   open my $fh, "<", $path
+   open my $fh, "<:raw:perlio:utf8", $path
       or Carp::croak "$path: $!";
    binmode $fh;
    my $parse_block; $parse_block = sub {
          }
          $prev = $arc;
          $more = undef;
       } elsif (/^arch (\S+)$/i) {
          my $name = $1;
-         my $arc = normalize_object $parse_block->(_name => $name);
+         my $arc = normalize_arch $parse_block->(_name => $name);
          if ($more) {
             $more->{more} = $arc;
          } else {
             push @{ $arc{arch} }, $arc;
          }
          $prev = $arc;
          $more = undef;
+      } elsif ($toplevel && /^(\S+)\s+(.*)$/) {
+         if ($1 eq "lev_array") {
+            while (<$fh>) {
+               last if /^endplst\s*$/;
+               push @{$toplevel->{lev_array}}, $_+0;
+            }
+         } else {
+            $toplevel->{$1} = $2;
+         }
       } elsif (/^\s*($|#)/) {
          #
       } else {
-         warn "$path: unparseable top-level line '$_'";
+         die "$path: unparseable top-level line '$_'";
       }
    }
    undef $parse_block; # work around bug in perl not freeing $fh etc.
 sub editor_archs {
    my %paths;
    for (keys %ARCH) {
       my $arch = $ARCH{$_};
-      push @{$paths{$arch->{editor_folder}}}, \$arch;
+      push @{$paths{$arch->{editor_folder}}}, $arch;
    }
    \%paths
 }
    my $type = $obj->{type} || $arch->{type};
    if ($type > 0) {
       $root = $Crossfire::Data::ATTR{$type};
    } else {
+      my %a = (%$arch, %$obj);
+      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};
+         $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);
    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 ();
+         my $pb = new Gtk2::Gdk::PixbufLoader;
-         print $fh $tile->{$name};
+         $pb->write ($tile->{$name});
-         close $fh;
+         $pb->close;
-         my $pb = new_from_file Gtk2::Gdk::Pixbuf $filename;
+         my $pb = $pb->get_pixbuf;
-         unlink $filename;
          my $tile = $cache{$name} = {
             pb  => $pb,
             idx => $idx,
             w   => int $pb->get_width  / TILESIZE,
                                 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
             }
          }
       }
-      $pb->save ("$VARDIR/tilecache.png", "png");
+      $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
       \%cache
    };
 }

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing deliantra/Deliantra/Deliantra.pm (file contents): Revision 1.56 by root, Thu Mar 23 07:33:16 2006 UTC vs. Revision 1.64 by root, Sun Apr 2 20:17:23 2006 UTC

Diff Legend

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.56 by root, Thu Mar 23 07:33:16 2006 UTC vs.
Revision 1.64 by root, Sun Apr 2 20:17:23 2006 UTC