ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra/Deliantra.pm
(Generate patch)

Comparing deliantra/Deliantra/Deliantra.pm (file contents):
Revision 1.126 by root, Tue Sep 9 09:50:24 2008 UTC vs.
Revision 1.146 by root, Sun Nov 11 23:31:42 2012 UTC

1=head1 NAME 1=head1 NAME
2 2
3Deliantra - Deliantra suppport module to read/write archetypes, maps etc. 3Deliantra - Deliantra suppport module to read/write archetypes, maps etc.
4 4
5=over 4
6
5=cut 7=cut
6 8
7package Deliantra; 9package Deliantra;
8 10
9our $VERSION = '1.221'; 11our $VERSION = '2.0';
10 12
11use strict; 13use common::sense;
12 14
13use base 'Exporter'; 15use base 'Exporter';
14 16
15use Carp (); 17use Carp ();
16use File::Spec; 18use File::Spec;
… …
54 56
55# same as in server save routine, to (hopefully) be compatible 57# same as in server save routine, to (hopefully) be compatible
56# to the other editors. 58# to the other editors.
57our @FIELD_ORDER_MAP = (qw( 59our @FIELD_ORDER_MAP = (qw(
58 file_format_version 60 file_format_version
59 name attach swap_time reset_timeout fixed_resettime difficulty region 61 name attach swap_time reset_timeout fixed_resettime difficulty
62 region music
60 shopitems shopgreed shopmin shopmax shoprace 63 shopitems shopgreed shopmin shopmax shoprace
61 darkness width height enter_x enter_y msg maplore 64 darkness width height enter_x enter_y msg maplore
62 unique template 65 unique template
63 outdoor temp pressure humid windspeed winddir sky nosmooth 66 outdoor temp pressure humid windspeed winddir sky nosmooth
64 tile_path_1 tile_path_2 tile_path_3 tile_path_4 67 tile_path_1 tile_path_2 tile_path_3 tile_path_4
… …
69 72
70 elevation 73 elevation
71 74
72 name name_pl custom_name attach title race 75 name name_pl custom_name attach title race
73 slaying skill msg lore other_arch 76 slaying skill msg lore other_arch
74 face animation is_animated 77 sound sound_destroy face animation is_animated
75 magicmap smoothlevel smoothface 78 magicmap glyph smoothlevel smoothface
76 str dex con wis pow cha int 79 str dex con wis pow cha int
77 hp maxhp sp maxsp grace maxgrace 80 hp maxhp sp maxsp grace maxgrace
78 exp perm_exp expmul 81 exp perm_exp expmul
79 food dam luck wc ac x y speed speed_left move_state attack_movement 82 food dam luck wc ac x y speed speed_left move_state attack_movement
80 nrof level direction type subtype attacktype 83 nrof level direction type subtype attacktype
… …
130 trigger => 10, 133 trigger => 10,
131 close => 11, 134 close => 11,
132 timer => 12, 135 timer => 12,
133); 136);
134 137
138# 1 up 2 right 4 down 8 left
139our %WALLDIR = (
140 0 => 0,
141 1_2 => 1,
142 1_4 => 2,
143 2_2_1 => 3,
144 1_1 => 4,
145 2_1_1 => 5,
146 2_2_2 => 6,
147 3_2 => 7,
148 1_3 => 8,
149 2_2_4 => 9,
150 2_1_2 => 10,
151 3_1 => 11,
152 2_2_3 => 12,
153 3_4 => 13,
154 3_3 => 14,
155 4 => 15,
156);
157
135sub MOVE_WALK (){ 0x01 } 158sub MOVE_WALK (){ 0x01 }
136sub MOVE_FLY_LOW (){ 0x02 } 159sub MOVE_FLY_LOW (){ 0x02 }
137sub MOVE_FLY_HIGH (){ 0x04 } 160sub MOVE_FLY_HIGH (){ 0x04 }
138sub MOVE_FLYING (){ 0x06 } 161sub MOVE_FLYING (){ 0x06 }
139sub MOVE_SWIM (){ 0x08 } 162sub MOVE_SWIM (){ 0x08 }
… …
151 boat => MOVE_BOAT, 174 boat => MOVE_BOAT,
152 ship => MOVE_SHIP, 175 ship => MOVE_SHIP,
153 all => MOVE_ALL, 176 all => MOVE_ALL,
154); 177);
155 178
156our @MOVE_TYPE = keys %MOVE_TYPE; 179our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat ship);
157 180
158{ 181{
159 package Deliantra::MoveType; 182 package Deliantra::MoveType;
160 183
161 use overload 184 use overload
162 '=' => sub { bless [@{$_[0]}], ref $_[0] }, 185 '=' => sub { bless [@{$_[0]}], ref $_[0] },
163 '""' => \&as_string, 186 '""' => \&as_string,
164 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 187 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
188 '<=' => sub {
189 ($_[0][0] & $MOVE_TYPE{$_[1]}) == $MOVE_TYPE{$_[1]}
190 ? $_[0][1] & $MOVE_TYPE{$_[1]}
191 : undef
192 },
165 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise }, 193 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
166 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 194 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 195 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
168 'x=' => sub { 196 'x=' => sub { # toggle between off, + and -
169 my $cur = $_[0] >= $_[1]; 197 my $cur = $_[0] >= $_[1];
170 if (!defined $cur) { 198 if (!defined $cur) {
171 if ($_[0] >= "all") { 199 if ($_[0] >= "all") {
172 $_[0] -= $_[1]; 200 $_[0] -= $_[1];
173 } else { 201 } else {
… …
182 $_[0] 210 $_[0]
183 }, 211 },
184 'eq' => sub { "$_[0]" eq "$_[1]" }, 212 'eq' => sub { "$_[0]" eq "$_[1]" },
185 'ne' => sub { "$_[0]" ne "$_[1]" }, 213 'ne' => sub { "$_[0]" ne "$_[1]" },
186 ; 214 ;
215
216 sub TO_JSON {
217 $_[0][0]
218 }
187} 219}
188 220
189sub Deliantra::MoveType::new { 221sub Deliantra::MoveType::new {
190 my ($class, $string) = @_; 222 my ($class, $string) = @_;
191 223
… …
333 365
334# object as in "Object xxx", i.e. archetypes 366# object as in "Object xxx", i.e. archetypes
335sub normalize_object($) { 367sub normalize_object($) {
336 my ($ob) = @_; 368 my ($ob) = @_;
337 369
370 delete $ob->{editable}; # deprecated
371
338 # convert material bitset to materialname, if possible 372 # convert material bitset to materialname, if possible
339 if (exists $ob->{material}) { 373 if (exists $ob->{material}) {
340 if (!$ob->{material}) { 374 if (!$ob->{material}) {
341 delete $ob->{material}; 375 delete $ob->{material};
342 } elsif (exists $ob->{materialname}) { 376 } elsif (exists $ob->{materialname}) {
… …
385 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr}; 419 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
386 } 420 }
387 421
388 # convert outdated movement flags to new movement sets 422 # convert outdated movement flags to new movement sets
389 if (defined (my $v = delete $ob->{no_pass})) { 423 if (defined (my $v = delete $ob->{no_pass})) {
390 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : ""; 424 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "0";
391 } 425 }
392 if (defined (my $v = delete $ob->{slow_move})) { 426 if (defined (my $v = delete $ob->{slow_move})) {
393 $ob->{move_slow} += "walk"; 427 $ob->{move_slow} += "walk";
394 $ob->{move_slow_penalty} = $v; 428 $ob->{move_slow_penalty} = $v;
395 } 429 }
396 if (defined (my $v = delete $ob->{walk_on})) { 430 if (defined (my $v = delete $ob->{walk_on})) {
397 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" } 431 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
398 } 432 }
399 if (defined (my $v = delete $ob->{walk_off})) { 433 if (defined (my $v = delete $ob->{walk_off})) {
400 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" } 434 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
401 } 435 }
402 if (defined (my $v = delete $ob->{fly_on})) { 436 if (defined (my $v = delete $ob->{fly_on})) {
… …
430# arch as in "arch xxx", ie.. objects 464# arch as in "arch xxx", ie.. objects
431sub normalize_arch($) { 465sub normalize_arch($) {
432 my ($ob) = @_; 466 my ($ob) = @_;
433 467
434 normalize_object $ob; 468 normalize_object $ob;
469
470 return if $ob->{_atype} eq "object";
435 471
436 my $arch = $ARCH{$ob->{_name}} 472 my $arch = $ARCH{$ob->{_name}}
437 or (warn "$ob->{_name}: no such archetype", return $ob); 473 or (warn "$ob->{_name}: no such archetype", return $ob);
438 474
439 if ($arch->{type} == 22) { # map 475 if ($arch->{type} == 22) { # map
… …
514 550
515 my %arc; 551 my %arc;
516 my ($more, $prev); 552 my ($more, $prev);
517 my $comment; 553 my $comment;
518 554
519 open my $fh, "<:raw:perlio:utf8", $path 555 open my $fh, "<:utf8", $path
520 or Carp::croak "$path: $!"; 556 or Carp::croak "$path: $!";
521 557
522# binmode $fh; 558# binmode $fh;
523 559
524 my $parse_block; $parse_block = sub { 560 my $parse_block; $parse_block = sub {
… …
799 } else { 835 } else {
800 $root = $Deliantra::Data::TYPE{Misc}; 836 $root = $Deliantra::Data::TYPE{Misc};
801 } 837 }
802 } 838 }
803 839
840 my (%ignore);
804 my @import = ($root); 841 my @import = ($root);
805
806 unshift @import, \%Deliantra::Data::DEFAULT_ATTR
807 unless $type == 116;
808 842
809 my (%ignore); 843 my @new_import;
810 my (@section_order, %section, @attr_order);
811
812 while (my $type = shift @import) { 844 while (my $type = shift @import) {
845 # first import everything we will need:
813 push @import, 846 push @import,
814 grep $_, 847 grep $_,
815 map $Deliantra::Data::TYPE{$_}, 848 map $Deliantra::Data::TYPE{$_},
816 @{$type->{import} || []}; 849 @{$type->{import} || []};
817 850
851 # and compute the ignored attributes
852 for (@{$type->{ignore} || []}) {
853 $ignore{$_}++ for ref $_ ? @$_ : $_;
854 }
855
856 push @new_import, $type;
857 }
858 (@import) = @new_import;
859
860 # then add defaults to the back of the list, so they are added
861 # as last resort.
862 push @import, \%Deliantra::Data::DEFAULT_ATTR
863 unless $type == 116;
864
865 my (@section_order, %section, @attr_order);
866
867 # @import = root, imported, default
868 while (my $type = pop @import) {
818 $attr->{$_} ||= $type->{$_} 869 $attr->{$_} ||= $type->{$_}
819 for qw(name desc use); 870 for qw(name desc use);
820
821 for (@{$type->{ignore} || []}) {
822 $ignore{$_}++ for ref $_ ? @$_ : $_;
823 }
824 871
825 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) { 872 for ([general => ($type->{attr} || [])], @{$type->{section} || []}) {
826 my ($name, $attr) = @$_; 873 my ($name, $attr) = @$_;
827 push @section_order, $name; 874 push @section_order, $name;
828 for (@$attr) { 875 for (@$attr) {
829 my ($k, $v) = @$_; 876 my ($k, $v) = @$_;
830 push @attr_order, $k; 877 push @attr_order, $k;
831 $section{$name}{$k} ||= $v; 878 $section{$name}{$k} = $v; # overwrite, so that the root decides
832 }
833 } 879 }
880 }
881 }
882
883 # remove ignores for "root" type
884 for (
885 map @{$_->[1]}, # section attributes
886 [general => ($root->{attr} || [])],
887 @{$root->{section} || []}
888 ) {
889 my ($k, $v) = @$_;
890 # skip fixed attributes, if they are ignored thats fine
891 next if $v->{type} eq 'fixed';
892
893 delete $ignore{$k}; # if the attributes are defined explicitly they
894 # should NOT be ignored. ignore should mainly
895 # hit imported/inherited attributes.
834 } 896 }
835 897
836 $attr->{section} = [ 898 $attr->{section} = [
837 map !exists $section{$_} ? () : do { 899 map !exists $section{$_} ? () : do {
838 my $attr = delete $section{$_}; 900 my $attr = delete $section{$_};
… …
842 map exists $attr->{$_} && !$ignore{$_} 904 map exists $attr->{$_} && !$ignore{$_}
843 ? [$_ => delete $attr->{$_}] : (), 905 ? [$_ => delete $attr->{$_}] : (),
844 @attr_order 906 @attr_order
845 ] 907 ]
846 }, 908 },
847
848 exists $section{$_} ? [$_ => delete $section{$_}] : (), 909 exists $section{$_} ? [$_ => delete $section{$_}] : (),
849 @section_order 910 @section_order
850 ]; 911 ];
851 912
852 $attr 913 $attr
853} 914}
… …
949 require Gtk2; 1010 require Gtk2;
950 1011
951 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache, 1012 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
952 sub { 1013 sub {
953 my %cache; 1014 my %cache;
954 my $facedata = Storable::retrieve "$LIB/facedata"; 1015 my $facedata = Storable::retrieve "$LIB/faceinfo";
1016
1017 open my $fh, "<", "$LIB/facedata"
1018 or die "$LIB/facedata: $!";
955 1019
956 $facedata->{version} == 2 1020 $facedata->{version} == 2
957 or die "$LIB/facedata: version mismatch, cannot proceed."; 1021 or die "$LIB/facedata: version mismatch, cannot proceed.";
958 1022
959 my $faces = $facedata->{faceinfo}; 1023 my $faces = $facedata->{faceinfo};
… …
961 1025
962 for (sort keys %$faces) { 1026 for (sort keys %$faces) {
963 my ($face, $info) = ($_, $faces->{$_}); 1027 my ($face, $info) = ($_, $faces->{$_});
964 1028
965 my $pb = new Gtk2::Gdk::PixbufLoader; 1029 my $pb = new Gtk2::Gdk::PixbufLoader;
1030
1031 if (exists $info->{data32}) {
966 $pb->write ($info->{data32}); 1032 $pb->write ($info->{data32});
1033 } else {
1034 sysseek $fh, $info->{fofs32}, 0;
1035 sysread $fh, my $buf, $info->{size32};
1036 $pb->write ($buf);
1037 }
967 $pb->close; 1038 $pb->close;
968 my $pb = $pb->get_pixbuf; 1039 my $pb = $pb->get_pixbuf;
969 1040
970 my $tile = $cache{$face} = { 1041 my $tile = $cache{$face} = {
971 pb => $pb, 1042 pb => $pb,
… …
981 1052
982 \%cache 1053 \%cache
983 }; 1054 };
984} 1055}
985 1056
1057=back
1058
986=head1 AUTHOR 1059=head1 AUTHOR
987 1060
988 Marc Lehmann <schmorp@schmorp.de> 1061 Marc Lehmann <schmorp@schmorp.de>
989 http://home.schmorp.de/ 1062 http://home.schmorp.de/
990 1063

Diff Legend

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