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.106 by root, Mon Apr 23 19:09:48 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
… …
138sub MOVE_FLY_LOW (){ 0x02 } 130sub MOVE_FLY_LOW (){ 0x02 }
139sub MOVE_FLY_HIGH (){ 0x04 } 131sub MOVE_FLY_HIGH (){ 0x04 }
140sub MOVE_FLYING (){ 0x06 } 132sub MOVE_FLYING (){ 0x06 }
141sub MOVE_SWIM (){ 0x08 } 133sub MOVE_SWIM (){ 0x08 }
142sub MOVE_BOAT (){ 0x10 } 134sub MOVE_BOAT (){ 0x10 }
135sub MOVE_SHIP (){ 0x20 }
143sub MOVE_KNOWN (){ 0x1f } # all of above 136sub MOVE_KNOWN (){ 0x3f } # all of above
144sub MOVE_ALL (){ 0x10000 } # very special value 137sub MOVE_ALL (){ 0x10000 } # very special value
145 138
146our %MOVE_TYPE = ( 139our %MOVE_TYPE = (
147 walk => MOVE_WALK, 140 walk => MOVE_WALK,
148 fly_low => MOVE_FLY_LOW, 141 fly_low => MOVE_FLY_LOW,
149 fly_high => MOVE_FLY_HIGH, 142 fly_high => MOVE_FLY_HIGH,
150 flying => MOVE_FLYING, 143 flying => MOVE_FLYING,
151 swim => MOVE_SWIM, 144 swim => MOVE_SWIM,
152 boat => MOVE_BOAT, 145 boat => MOVE_BOAT,
146 ship => MOVE_SHIP,
153 all => MOVE_ALL, 147 all => MOVE_ALL,
154); 148);
155 149
156our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat); 150our @MOVE_TYPE = keys %MOVE_TYPE;
157 151
158{ 152{
159 package Crossfire::MoveType; 153 package Crossfire::MoveType;
160 154
161 use overload 155 use overload
156 '=' => sub { bless [@{$_[0]}], ref $_[0] },
162 '""' => \&as_string, 157 '""' => \&as_string,
163 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 158 '>=' => 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 }, 159 '+=' => 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 }, 160 '-=' => sub { $_[0][0] |= $MOVE_TYPE{$_[1]}; $_[0][1] &= ~$MOVE_TYPE{$_[1]}; &normalise },
166 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise }, 161 '/=' => sub { $_[0][0] &= ~$MOVE_TYPE{$_[1]}; &normalise },
167 'x=' => sub { 162 'x=' => sub {
168 my $cur = $_[0] >= $_[1]; 163 my $cur = $_[0] >= $_[1];
169 if (!defined $cur) { 164 if (!defined $cur) {
165 if ($_[0] >= "all") {
166 $_[0] -= $_[1];
167 } else {
170 $_[0] += $_[1]; 168 $_[0] += $_[1];
169 }
171 } elsif ($cur) { 170 } elsif ($cur) {
172 $_[0] -= $_[1]; 171 $_[0] -= $_[1];
173 } else { 172 } else {
174 $_[0] /= $_[1]; 173 $_[0] /= $_[1];
175 } 174 }
176 175
177 $_[0] 176 $_[0]
178 }, 177 },
178 'eq' => sub { "$_[0]" eq "$_[1]" },
179 'ne' => sub { "$_[0]" ne "$_[1]" },
179 ; 180 ;
180} 181}
181 182
182sub Crossfire::MoveType::new { 183sub Crossfire::MoveType::new {
183 my ($class, $string) = @_; 184 my ($class, $string) = @_;
184 185
185 my $mask; 186 my $mask;
186 my $value; 187 my $value;
187 188
189 if ($string =~ /^\s*\d+\s*$/) {
190 $mask = MOVE_ALL;
191 $value = $string+0;
192 } else {
188 for (split /\s+/, lc $string) { 193 for (split /\s+/, lc $string) {
189 if (s/^-//) { 194 if (s/^-//) {
190 $mask |= $MOVE_TYPE{$_}; 195 $mask |= $MOVE_TYPE{$_};
191 $value &= ~$MOVE_TYPE{$_}; 196 $value &= ~$MOVE_TYPE{$_};
192 } else { 197 } else {
193 $mask |= $MOVE_TYPE{$_}; 198 $mask |= $MOVE_TYPE{$_};
194 $value |= $MOVE_TYPE{$_}; 199 $value |= $MOVE_TYPE{$_};
200 }
195 } 201 }
196 } 202 }
197 203
198 (bless [$mask, $value], $class)->normalise 204 (bless [$mask, $value], $class)->normalise
199} 205}
… …
340 } else { 346 } else {
341 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; 347 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
342 } 348 }
343 } 349 }
344 350
351 # color_fg is used as default for magicmap if magicmap does not exist
352 $ob->{magicmap} ||= delete $ob->{color_fg} if exists $ob->{color_fg};
353
345 # nuke outdated or never supported fields 354 # nuke outdated or never supported fields
346 delete @$ob{qw( 355 delete @$ob{qw(
347 can_knockback can_parry can_impale can_cut can_dam_armour 356 can_knockback can_parry can_impale can_cut can_dam_armour
348 can_apply pass_thru can_pass_thru 357 can_apply pass_thru can_pass_thru color_bg color_fg
349 )}; 358 )};
350 359
351 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } 360 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
352 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } 361 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
353 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } 362 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
… …
878 }, sub { 887 }, sub {
879 read_arch "$LIB/archetypes" 888 read_arch "$LIB/archetypes"
880 }; 889 };
881} 890}
882 891
892sub construct_tilecache_pb {
893 my ($idx, $cache) = @_;
894
895 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
896
897 while (my ($name, $tile) = each %$cache) {
898 my $tpb = delete $tile->{pb};
899 my $ofs = $tile->{idx};
900
901 for my $x (0 .. $tile->{w} - 1) {
902 for my $y (0 .. $tile->{h} - 1) {
903 my $idx = $ofs + $x + $y * $tile->{w};
904 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
905 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
906 }
907 }
908 }
909
910 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
911
912 $cache
913}
914
915sub use_tilecache {
916 my ($face) = @_;
917 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png"
918 or die "$VARDIR/tilecache.png: $!";
919 *FACE = $_[0];
920}
921
883=item load_tilecache 922=item load_tilecache
884 923
885(Re-)Load %TILE and %FACE. 924(Re-)Load %TILE and %FACE.
886 925
887=cut 926=cut
888 927
889sub load_tilecache() { 928sub load_tilecache() {
890 require Gtk2; 929 require Gtk2;
891 930
931 if (-e "$LIB/crossfire.0") { # Crossfire1 version
892 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 932 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
893 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 933 sub {
894 or die "$VARDIR/tilecache.png: $!";
895 *FACE = $_[0];
896 }, sub {
897 my $tile = read_pak "$LIB/crossfire.0"; 934 my $tile = read_pak "$LIB/crossfire.0";
898 935
899 my %cache; 936 my %cache;
900 937
901 my $idx = 0; 938 my $idx = 0;
902 939
903 for my $name (sort keys %$tile) { 940 for my $name (sort keys %$tile) {
904 my $pb = new Gtk2::Gdk::PixbufLoader; 941 my $pb = new Gtk2::Gdk::PixbufLoader;
905 $pb->write ($tile->{$name}); 942 $pb->write ($tile->{$name});
906 $pb->close; 943 $pb->close;
907 my $pb = $pb->get_pixbuf; 944 my $pb = $pb->get_pixbuf;
908 945
909 my $tile = $cache{$name} = { 946 my $tile = $cache{$name} = {
910 pb => $pb, 947 pb => $pb,
911 idx => $idx, 948 idx => $idx,
912 w => int $pb->get_width / TILESIZE, 949 w => int $pb->get_width / TILESIZE,
913 h => int $pb->get_height / TILESIZE, 950 h => int $pb->get_height / TILESIZE,
951 };
952
953 $idx += $tile->{w} * $tile->{h};
954 }
955
956 construct_tilecache_pb $idx, \%cache;
957
958 \%cache
914 }; 959 };
960
961 } else { # Crossfire+ version
962 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
963 sub {
964 my %cache;
965 my $facedata = Storable::retrieve "$LIB/facedata";
966
967 $facedata->{version} == 2
968 or die "$LIB/facedata: version mismatch, cannot proceed.";
969
970 my $faces = $facedata->{faceinfo};
971 my $idx = 0;
972
973 for (sort keys %$faces) {
974 my ($face, $info) = ($_, $faces->{$_});
975
976 my $pb = new Gtk2::Gdk::PixbufLoader;
977 $pb->write ($info->{data32});
978 $pb->close;
979 my $pb = $pb->get_pixbuf;
980
981 my $tile = $cache{$face} = {
982 pb => $pb,
983 idx => $idx,
984 w => int $pb->get_width / TILESIZE,
985 h => int $pb->get_height / TILESIZE,
915 986 };
916 987
917 $idx += $tile->{w} * $tile->{h}; 988 $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 } 989 }
990
991 construct_tilecache_pb $idx, \%cache;
992
993 \%cache
932 } 994 };
933 }
934
935 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
936
937 \%cache
938 }; 995 }
939} 996}
940 997
941=head1 AUTHOR 998=head1 AUTHOR
942 999
943 Marc Lehmann <schmorp@schmorp.de> 1000 Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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