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

Diff Legend

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