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.90 by root, Sat Mar 3 18:58:25 2007 UTC vs.
Revision 1.102 by elmex, Sun Apr 15 11:43:03 2007 UTC

… …
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Crossfire;
8 8
9our $VERSION = '0.96'; 9our $VERSION = '0.98';
10 10
11use strict; 11use strict;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
… …
19 19
20our @EXPORT = qw( 20our @EXPORT = qw(
21 read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents 21 read_pak read_arch *ARCH TILESIZE $TILE *FACE editor_archs arch_extents
22); 22);
23 23
24use JSON::Syck (); #TODO#d# replace by JSON::PC when it becomes available == working 24use JSON::XS qw(from_json to_json);
25
26sub from_json($) {
27 $JSON::Syck::ImplicitUnicode = 1;
28 JSON::Syck::Load $_[0]
29}
30
31sub to_json($) {
32 $JSON::Syck::ImplicitUnicode = 0;
33 JSON::Syck::Dump $_[0]
34}
35 25
36our $LIB = $ENV{CROSSFIRE_LIBDIR}; 26our $LIB = $ENV{CROSSFIRE_LIBDIR};
37 27
38our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" 28our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire"
39 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire" 29 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire"
… …
71 61
72our @FIELD_ORDER = (qw( 62our @FIELD_ORDER = (qw(
73 elevation 63 elevation
74 64
75 name name_pl custom_name attach title race 65 name name_pl custom_name attach title race
76 slaying skill msg lore other_arch face 66 slaying skill msg lore other_arch
77 #todo-events 67 is_animated animation face
78 animation is_animated 68 magicmap smoothlevel smoothface
79 str dex con wis pow cha int 69 str dex con wis pow cha int
80 hp maxhp sp maxsp grace maxgrace 70 hp maxhp sp maxsp grace maxgrace
81 exp perm_exp expmul 71 exp perm_exp expmul
82 food dam luck wc ac x y speed speed_left move_state attack_movement 72 food dam luck wc ac x y speed speed_left move_state attack_movement
83 nrof level direction type subtype attacktype 73 nrof level direction type subtype attacktype
… …
157 147
158{ 148{
159 package Crossfire::MoveType; 149 package Crossfire::MoveType;
160 150
161 use overload 151 use overload
152 '=' => sub { bless [@{$_[0]}], ref $_[0] },
162 '""' => \&as_string, 153 '""' => \&as_string,
163 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 154 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
164 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise }, 155 '+=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] |= $MOVE_TYPE{$_[1]}; &normalise },
165 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 156 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
166 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 157 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 'x=' => sub { 158 'x=' => sub {
168 my $cur = $_[0] >= $_[1]; 159 my $cur = $_[0] >= $_[1];
169 if (!defined $cur) { 160 if (!defined $cur) {
161 if ($_[0] >= "all") {
162 $_[0] -= $_[1];
163 } else {
170 $_[0] += $_[1]; 164 $_[0] += $_[1];
165 }
171 } elsif ($cur) { 166 } elsif ($cur) {
172 $_[0] -= $_[1]; 167 $_[0] -= $_[1];
173 } else { 168 } else {
174 $_[0] /= $_[1]; 169 $_[0] /= $_[1];
175 } 170 }
176 171
177 $_[0] 172 $_[0]
178 }, 173 },
174 'eq' => sub { "$_[0]" eq "$_[1]" },
175 'ne' => sub { "$_[0]" ne "$_[1]" },
179 ; 176 ;
180} 177}
181 178
182sub Crossfire::MoveType::new { 179sub Crossfire::MoveType::new {
183 my ($class, $string) = @_; 180 my ($class, $string) = @_;
184 181
185 my $mask; 182 my $mask;
186 my $value; 183 my $value;
187 184
185 if ($string =~ /^\s*\d+\s*$/) {
186 $mask = MOVE_ALL;
187 $value = $string+0;
188 } else {
188 for (split /\s+/, lc $string) { 189 for (split /\s+/, lc $string) {
189 if (s/^-//) { 190 if (s/^-//) {
190 $mask |= $MOVE_TYPE{$_}; 191 $mask |= $MOVE_TYPE{$_};
191 $value &= ~$MOVE_TYPE{$_}; 192 $value &= ~$MOVE_TYPE{$_};
192 } else { 193 } else {
193 $mask |= $MOVE_TYPE{$_}; 194 $mask |= $MOVE_TYPE{$_};
194 $value |= $MOVE_TYPE{$_}; 195 $value |= $MOVE_TYPE{$_};
196 }
195 } 197 }
196 } 198 }
197 199
198 (bless [$mask, $value], $class)->normalise 200 (bless [$mask, $value], $class)->normalise
199} 201}
… …
340 } else { 342 } else {
341 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; 343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
342 } 344 }
343 } 345 }
344 346
347 # color_fg is used as default for magicmap if magicmap does not exist
348 $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg};
349
345 # nuke outdated or never supported fields 350 # nuke outdated or never supported fields
346 delete @$ob{qw( 351 delete @$ob{qw(
347 can_knockback can_parry can_impale can_cut can_dam_armour 352 can_knockback can_parry can_impale can_cut can_dam_armour
348 can_apply pass_thru can_pass_thru 353 can_apply pass_thru can_pass_thru color_bg color_fg
349 )}; 354 )};
350 355
351 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } 356 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
352 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } 357 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
353 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } 358 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
… …
878 }, sub { 883 }, sub {
879 read_arch "$LIB/archetypes" 884 read_arch "$LIB/archetypes"
880 }; 885 };
881} 886}
882 887
888sub construct_tilecache_pb {
889 my ($idx, $cache) = @_;
890
891 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
892
893 while (my ($name, $tile) = each %$cache) {
894 my $tpb = delete $tile->{pb};
895 my $ofs = $tile->{idx};
896
897 for my $x (0 .. $tile->{w} - 1) {
898 for my $y (0 .. $tile->{h} - 1) {
899 my $idx = $ofs + $x + $y * $tile->{w};
900 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
901 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
902 }
903 }
904 }
905
906 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
907
908 $cache
909}
910
911sub use_tilecache {
912 my ($face) = @_;
913 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
914 or die "$VARDIR/tilecache.png: $!";
915 *FACE = $_[0];
916}
917
883=item load_tilecache 918=item load_tilecache
884 919
885(Re-)Load %TILE and %FACE. 920(Re-)Load %TILE and %FACE.
886 921
887=cut 922=cut
888 923
889sub load_tilecache() { 924sub load_tilecache() {
890 require Gtk2; 925 require Gtk2;
891 926
927 if (-e "$LIB/crossfire.0") { # Crossfire1 version
892 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 928 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
893 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 929 sub {
894 or die "$VARDIR/tilecache.png: $!";
895 *FACE = $_[0];
896 }, sub {
897 my $tile = read_pak "$LIB/crossfire.0"; 930 my $tile = read_pak "$LIB/crossfire.0";
898 931
899 my %cache; 932 my %cache;
900 933
901 my $idx = 0; 934 my $idx = 0;
902 935
903 for my $name (sort keys %$tile) { 936 for my $name (sort keys %$tile) {
904 my $pb = new Gtk2::Gdk::PixbufLoader; 937 my $pb = new Gtk2::Gdk::PixbufLoader;
905 $pb->write ($tile->{$name}); 938 $pb->write ($tile->{$name});
906 $pb->close; 939 $pb->close;
907 my $pb = $pb->get_pixbuf; 940 my $pb = $pb->get_pixbuf;
908 941
909 my $tile = $cache{$name} = { 942 my $tile = $cache{$name} = {
910 pb => $pb, 943 pb => $pb,
911 idx => $idx, 944 idx => $idx,
912 w => int $pb->get_width / TILESIZE, 945 w => int $pb->get_width / TILESIZE,
913 h => int $pb->get_height / TILESIZE, 946 h => int $pb->get_height / TILESIZE,
947 };
948
949 $idx += $tile->{w} * $tile->{h};
950 }
951
952 construct_tilecache_pb $idx, \%cache;
953
954 \%cache
914 }; 955 };
956
957 } else { # Crossfire+ version
958 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
959 sub {
960 my %cache;
961 my $facedata = Storable::retrieve "$LIB/facedata";
962
963 $facedata->{version} == 2
964 or die "$LIB/facedata: version mismatch, cannot proceed.";
965
966 my $faces = $facedata->{faceinfo};
967 my $idx = 0;
968
969 for (sort keys %$faces) {
970 my ($face, $info) = ($_, $faces->{$_});
971
972 my $pb = new Gtk2::Gdk::PixbufLoader;
973 $pb->write ($info->{data32});
974 $pb->close;
975 my $pb = $pb->get_pixbuf;
976
977 my $tile = $cache{$face} = {
978 pb => $pb,
979 idx => $idx,
980 w => int $pb->get_width / TILESIZE,
981 h => int $pb->get_height / TILESIZE,
915 982 };
916 983
917 $idx += $tile->{w} * $tile->{h}; 984 $idx += $tile->{w} * $tile->{h};
918 }
919
920 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
921
922 while (my ($name, $tile) = each %cache) {
923 my $tpb = delete $tile->{pb};
924 my $ofs = $tile->{idx};
925
926 for my $x (0 .. $tile->{w} - 1) {
927 for my $y (0 .. $tile->{h} - 1) {
928 my $idx = $ofs + $x + $y * $tile->{w};
929 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
930 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
931 } 985 }
986
987 construct_tilecache_pb $idx, \%cache;
988
989 \%cache
932 } 990 };
933 }
934
935 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
936
937 \%cache
938 }; 991 }
939} 992}
940 993
941=head1 AUTHOR 994=head1 AUTHOR
942 995
943 Marc Lehmann <schmorp@schmorp.de> 996 Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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