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

Diff Legend

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