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.91 by root, Sat Mar 3 19:06:03 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 }
… …
185 my ($class, $string) = @_; 180 my ($class, $string) = @_;
186 181
187 my $mask; 182 my $mask;
188 my $value; 183 my $value;
189 184
185 if ($string =~ /^\s*\d+\s*$/) {
186 $mask = MOVE_ALL;
187 $value = $string+0;
188 } else {
190 for (split /\s+/, lc $string) { 189 for (split /\s+/, lc $string) {
191 if (s/^-//) { 190 if (s/^-//) {
192 $mask |= $MOVE_TYPE{$_}; 191 $mask |= $MOVE_TYPE{$_};
193 $value &= ~$MOVE_TYPE{$_}; 192 $value &= ~$MOVE_TYPE{$_};
194 } else { 193 } else {
195 $mask |= $MOVE_TYPE{$_}; 194 $mask |= $MOVE_TYPE{$_};
196 $value |= $MOVE_TYPE{$_}; 195 $value |= $MOVE_TYPE{$_};
196 }
197 } 197 }
198 } 198 }
199 199
200 (bless [$mask, $value], $class)->normalise 200 (bless [$mask, $value], $class)->normalise
201} 201}
… …
342 } else { 342 } else {
343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; 343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
344 } 344 }
345 } 345 }
346 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
347 # nuke outdated or never supported fields 350 # nuke outdated or never supported fields
348 delete @$ob{qw( 351 delete @$ob{qw(
349 can_knockback can_parry can_impale can_cut can_dam_armour 352 can_knockback can_parry can_impale can_cut can_dam_armour
350 can_apply pass_thru can_pass_thru 353 can_apply pass_thru can_pass_thru color_bg color_fg
351 )}; 354 )};
352 355
353 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } 356 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
354 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } 357 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
355 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } 358 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
… …
880 }, sub { 883 }, sub {
881 read_arch "$LIB/archetypes" 884 read_arch "$LIB/archetypes"
882 }; 885 };
883} 886}
884 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
885=item load_tilecache 918=item load_tilecache
886 919
887(Re-)Load %TILE and %FACE. 920(Re-)Load %TILE and %FACE.
888 921
889=cut 922=cut
890 923
891sub load_tilecache() { 924sub load_tilecache() {
892 require Gtk2; 925 require Gtk2;
893 926
927 if (-e "$LIB/crossfire.0") { # Crossfire1 version
894 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 928 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
895 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 929 sub {
896 or die "$VARDIR/tilecache.png: $!";
897 *FACE = $_[0];
898 }, sub {
899 my $tile = read_pak "$LIB/crossfire.0"; 930 my $tile = read_pak "$LIB/crossfire.0";
900 931
901 my %cache; 932 my %cache;
902 933
903 my $idx = 0; 934 my $idx = 0;
904 935
905 for my $name (sort keys %$tile) { 936 for my $name (sort keys %$tile) {
906 my $pb = new Gtk2::Gdk::PixbufLoader; 937 my $pb = new Gtk2::Gdk::PixbufLoader;
907 $pb->write ($tile->{$name}); 938 $pb->write ($tile->{$name});
908 $pb->close; 939 $pb->close;
909 my $pb = $pb->get_pixbuf; 940 my $pb = $pb->get_pixbuf;
910 941
911 my $tile = $cache{$name} = { 942 my $tile = $cache{$name} = {
912 pb => $pb, 943 pb => $pb,
913 idx => $idx, 944 idx => $idx,
914 w => int $pb->get_width / TILESIZE, 945 w => int $pb->get_width / TILESIZE,
915 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
916 }; 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,
917 982 };
918 983
919 $idx += $tile->{w} * $tile->{h}; 984 $idx += $tile->{w} * $tile->{h};
920 }
921
922 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
923
924 while (my ($name, $tile) = each %cache) {
925 my $tpb = delete $tile->{pb};
926 my $ofs = $tile->{idx};
927
928 for my $x (0 .. $tile->{w} - 1) {
929 for my $y (0 .. $tile->{h} - 1) {
930 my $idx = $ofs + $x + $y * $tile->{w};
931 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
932 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
933 } 985 }
986
987 construct_tilecache_pb $idx, \%cache;
988
989 \%cache
934 } 990 };
935 }
936
937 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
938
939 \%cache
940 }; 991 }
941} 992}
942 993
943=head1 AUTHOR 994=head1 AUTHOR
944 995
945 Marc Lehmann <schmorp@schmorp.de> 996 Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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