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.92 by root, Sat Mar 3 19:32:00 2007 UTC vs.
Revision 1.104 by root, Mon Apr 16 12:32:30 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
78 animation is_animated 67 face 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 }
… …
347 } else { 342 } else {
348 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n"; 343 warn "object $ob->{_name} has unknown material ($ob->{material}) set.\n";
349 } 344 }
350 } 345 }
351 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
352 # nuke outdated or never supported fields 350 # nuke outdated or never supported fields
353 delete @$ob{qw( 351 delete @$ob{qw(
354 can_knockback can_parry can_impale can_cut can_dam_armour 352 can_knockback can_parry can_impale can_cut can_dam_armour
355 can_apply pass_thru can_pass_thru 353 can_apply pass_thru can_pass_thru color_bg color_fg
356 )}; 354 )};
357 355
358 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; } 356 if (my $mask = delete $ob->{immune} ) { _add_resist $ob, $mask, 100; }
359 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; } 357 if (my $mask = delete $ob->{protected} ) { _add_resist $ob, $mask, 30; }
360 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; } 358 if (my $mask = delete $ob->{vulnerable}) { _add_resist $ob, $mask, -100; }
… …
885 }, sub { 883 }, sub {
886 read_arch "$LIB/archetypes" 884 read_arch "$LIB/archetypes"
887 }; 885 };
888} 886}
889 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
890=item load_tilecache 918=item load_tilecache
891 919
892(Re-)Load %TILE and %FACE. 920(Re-)Load %TILE and %FACE.
893 921
894=cut 922=cut
895 923
896sub load_tilecache() { 924sub load_tilecache() {
897 require Gtk2; 925 require Gtk2;
898 926
927 if (-e "$LIB/crossfire.0") { # Crossfire1 version
899 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", sub { 928 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
900 $TILE = new_from_file Gtk2::Gdk::Pixbuf "$VARDIR/tilecache.png" 929 sub {
901 or die "$VARDIR/tilecache.png: $!";
902 *FACE = $_[0];
903 }, sub {
904 my $tile = read_pak "$LIB/crossfire.0"; 930 my $tile = read_pak "$LIB/crossfire.0";
905 931
906 my %cache; 932 my %cache;
907 933
908 my $idx = 0; 934 my $idx = 0;
909 935
910 for my $name (sort keys %$tile) { 936 for my $name (sort keys %$tile) {
911 my $pb = new Gtk2::Gdk::PixbufLoader; 937 my $pb = new Gtk2::Gdk::PixbufLoader;
912 $pb->write ($tile->{$name}); 938 $pb->write ($tile->{$name});
913 $pb->close; 939 $pb->close;
914 my $pb = $pb->get_pixbuf; 940 my $pb = $pb->get_pixbuf;
915 941
916 my $tile = $cache{$name} = { 942 my $tile = $cache{$name} = {
917 pb => $pb, 943 pb => $pb,
918 idx => $idx, 944 idx => $idx,
919 w => int $pb->get_width / TILESIZE, 945 w => int $pb->get_width / TILESIZE,
920 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
921 }; 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,
922 982 };
923 983
924 $idx += $tile->{w} * $tile->{h}; 984 $idx += $tile->{w} * $tile->{h};
925 }
926
927 my $pb = new Gtk2::Gdk::Pixbuf "rgb", 1, 8, 64 * TILESIZE, TILESIZE * int +($idx + 63) / 64;
928
929 while (my ($name, $tile) = each %cache) {
930 my $tpb = delete $tile->{pb};
931 my $ofs = $tile->{idx};
932
933 for my $x (0 .. $tile->{w} - 1) {
934 for my $y (0 .. $tile->{h} - 1) {
935 my $idx = $ofs + $x + $y * $tile->{w};
936 $tpb->copy_area ($x * TILESIZE, $y * TILESIZE, TILESIZE, TILESIZE,
937 $pb, ($idx % 64) * TILESIZE, TILESIZE * int $idx / 64);
938 } 985 }
986
987 construct_tilecache_pb $idx, \%cache;
988
989 \%cache
939 } 990 };
940 }
941
942 $pb->save ("$VARDIR/tilecache.png", "png", compression => 1);
943
944 \%cache
945 }; 991 }
946} 992}
947 993
948=head1 AUTHOR 994=head1 AUTHOR
949 995
950 Marc Lehmann <schmorp@schmorp.de> 996 Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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