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.112 by root, Thu Jun 21 00:07:54 2007 UTC vs.
Revision 1.132 by root, Wed Sep 2 22:38:57 2009 UTC

1=head1 NAME 1=head1 NAME
2 2
3Crossfire - Crossfire maphandling 3Deliantra - Deliantra suppport module to read/write archetypes, maps etc.
4 4
5=cut 5=cut
6 6
7package Crossfire; 7package Deliantra;
8 8
9our $VERSION = '1.0'; 9our $VERSION = '1.25';
10 10
11use strict; 11use common::sense;
12 12
13use base 'Exporter'; 13use base 'Exporter';
14 14
15use Carp (); 15use Carp ();
16use File::Spec; 16use File::Spec;
… …
22 *ARCH $TILE *FACE *FACEDATA 22 *ARCH $TILE *FACE *FACEDATA
23 TILESIZE CACHESTRIDE 23 TILESIZE CACHESTRIDE
24 editor_archs arch_extents 24 editor_archs arch_extents
25); 25);
26 26
27use JSON::XS qw(from_json to_json); 27use JSON::XS qw(decode_json encode_json);
28 28
29our $LIB = $ENV{CROSSFIRE_LIBDIR}; 29our $LIB = $ENV{DELIANTRA_LIBDIR};
30 30
31our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.crossfire" 31our $VARDIR = $ENV{HOME} ? "$ENV{HOME}/.deliantra"
32 : $ENV{AppData} ? "$ENV{APPDATA}/crossfire" 32 : $ENV{AppData} ? "$ENV{APPDATA}/deliantra"
33 : File::Spec->tmpdir . "/crossfire"; 33 : File::Spec->tmpdir . "/deliantra";
34 34
35mkdir $VARDIR, 0777; 35mkdir $VARDIR, 0777;
36 36
37sub TILESIZE (){ 32 } 37sub TILESIZE (){ 32 }
38sub CACHESTRIDE (){ 64 } 38sub CACHESTRIDE (){ 64 }
… …
69 69
70 elevation 70 elevation
71 71
72 name name_pl custom_name attach title race 72 name name_pl custom_name attach title race
73 slaying skill msg lore other_arch 73 slaying skill msg lore other_arch
74 face animation is_animated 74 sound sound_destroy face animation is_animated
75 magicmap smoothlevel smoothface 75 magicmap smoothlevel smoothface
76 str dex con wis pow cha int 76 str dex con wis pow cha int
77 hp maxhp sp maxsp grace maxgrace 77 hp maxhp sp maxsp grace maxgrace
78 exp perm_exp expmul 78 exp perm_exp expmul
79 food dam luck wc ac x y speed speed_left move_state attack_movement 79 food dam luck wc ac x y speed speed_left move_state attack_movement
… …
151 boat => MOVE_BOAT, 151 boat => MOVE_BOAT,
152 ship => MOVE_SHIP, 152 ship => MOVE_SHIP,
153 all => MOVE_ALL, 153 all => MOVE_ALL,
154); 154);
155 155
156our @MOVE_TYPE = keys %MOVE_TYPE; 156our @MOVE_TYPE = qw(all walk flying fly_low fly_high swim boat ship);
157 157
158{ 158{
159 package Crossfire::MoveType; 159 package Deliantra::MoveType;
160 160
161 use overload 161 use overload
162 '=' => sub { bless [@{$_[0]}], ref $_[0] }, 162 '=' => sub { bless [@{$_[0]}], ref $_[0] },
163 '""' => \&as_string, 163 '""' => \&as_string,
164 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef }, 164 '>=' => sub { $_[0][0] & $MOVE_TYPE{$_[1]} ? $_[0][1] & $MOVE_TYPE{$_[1]} : undef },
… …
182 $_[0] 182 $_[0]
183 }, 183 },
184 'eq' => sub { "$_[0]" eq "$_[1]" }, 184 'eq' => sub { "$_[0]" eq "$_[1]" },
185 'ne' => sub { "$_[0]" ne "$_[1]" }, 185 'ne' => sub { "$_[0]" ne "$_[1]" },
186 ; 186 ;
187}
188 187
189sub Crossfire::MoveType::new { 188 sub TO_JSON {
189 $_[0][0]
190 }
191}
192
193sub Deliantra::MoveType::new {
190 my ($class, $string) = @_; 194 my ($class, $string) = @_;
191 195
192 my $mask; 196 my $mask;
193 my $value; 197 my $value;
194 198
… …
208 } 212 }
209 213
210 (bless [$mask, $value], $class)->normalise 214 (bless [$mask, $value], $class)->normalise
211} 215}
212 216
213sub Crossfire::MoveType::normalise { 217sub Deliantra::MoveType::normalise {
214 my ($self) = @_; 218 my ($self) = @_;
215 219
216 if ($self->[0] & MOVE_ALL) { 220 if ($self->[0] & MOVE_ALL) {
217 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL); 221 my $mask = ~(($self->[1] & MOVE_ALL ? $self->[1] : ~$self->[1]) & $self->[0] & ~MOVE_ALL);
218 $self->[0] &= $mask; 222 $self->[0] &= $mask;
… …
222 $self->[1] &= $self->[0]; 226 $self->[1] &= $self->[0];
223 227
224 $self 228 $self
225} 229}
226 230
227sub Crossfire::MoveType::as_string { 231sub Deliantra::MoveType::as_string {
228 my ($self) = @_; 232 my ($self) = @_;
229 233
230 my @res; 234 my @res;
231 235
232 my ($mask, $value) = @$self; 236 my ($mask, $value) = @$self;
233 237
234 for (@Crossfire::MOVE_TYPE) { 238 for (@Deliantra::MOVE_TYPE) {
235 my $bit = $Crossfire::MOVE_TYPE{$_}; 239 my $bit = $Deliantra::MOVE_TYPE{$_};
236 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) { 240 if (($mask & $bit) == $bit && (($value & $bit) == $bit || ($value & $bit) == 0)) {
237 $mask &= ~$bit; 241 $mask &= ~$bit;
238 push @res, $value & $bit ? $_ : "-$_"; 242 push @res, $value & $bit ? $_ : "-$_";
239 } 243 }
240 } 244 }
… …
380 384
381 # convert movement strings to bitsets 385 # convert movement strings to bitsets
382 for my $attr (keys %FIELD_MOVEMENT) { 386 for my $attr (keys %FIELD_MOVEMENT) {
383 next unless exists $ob->{$attr}; 387 next unless exists $ob->{$attr};
384 388
385 $ob->{$attr} = new Crossfire::MoveType $ob->{$attr}; 389 $ob->{$attr} = new Deliantra::MoveType $ob->{$attr};
386 } 390 }
387 391
388 # convert outdated movement flags to new movement sets 392 # convert outdated movement flags to new movement sets
389 if (defined (my $v = delete $ob->{no_pass})) { 393 if (defined (my $v = delete $ob->{no_pass})) {
390 $ob->{move_block} = new Crossfire::MoveType $v ? "all" : ""; 394 $ob->{move_block} = new Deliantra::MoveType $v ? "all" : "";
391 } 395 }
392 if (defined (my $v = delete $ob->{slow_move})) { 396 if (defined (my $v = delete $ob->{slow_move})) {
393 $ob->{move_slow} += "walk"; 397 $ob->{move_slow} += "walk";
394 $ob->{move_slow_penalty} = $v; 398 $ob->{move_slow_penalty} = $v;
395 } 399 }
396 if (defined (my $v = delete $ob->{walk_on})) { 400 if (defined (my $v = delete $ob->{walk_on})) {
397 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" } 401 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "walk" } else { $ob->{move_on} -= "walk" }
398 } 402 }
399 if (defined (my $v = delete $ob->{walk_off})) { 403 if (defined (my $v = delete $ob->{walk_off})) {
400 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" } 404 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "walk" } else { $ob->{move_off} -= "walk" }
401 } 405 }
402 if (defined (my $v = delete $ob->{fly_on})) { 406 if (defined (my $v = delete $ob->{fly_on})) {
403 $ob->{move_on} ||= new Crossfire::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" } 407 $ob->{move_on} ||= new Deliantra::MoveType; if ($v) { $ob->{move_on} += "fly_low" } else { $ob->{move_on} -= "fly_low" }
404 } 408 }
405 if (defined (my $v = delete $ob->{fly_off})) { 409 if (defined (my $v = delete $ob->{fly_off})) {
406 $ob->{move_off} ||= new Crossfire::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" } 410 $ob->{move_off} ||= new Deliantra::MoveType; if ($v) { $ob->{move_off} += "fly_low" } else { $ob->{move_off} -= "fly_low" }
407 } 411 }
408 if (defined (my $v = delete $ob->{flying})) { 412 if (defined (my $v = delete $ob->{flying})) {
409 $ob->{move_type} ||= new Crossfire::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" } 413 $ob->{move_type} ||= new Deliantra::MoveType; if ($v) { $ob->{move_type} += "fly_low" } else { $ob->{move_type} -= "fly_low" }
410 } 414 }
411 415
412 # convert idiotic event_xxx things into objects 416 # convert idiotic event_xxx things into objects
413 while (my ($event, $subtype) = each %EVENT_TYPE) { 417 while (my ($event, $subtype) = each %EVENT_TYPE) {
414 if (exists $ob->{"event_${event}_plugin"}) { 418 if (exists $ob->{"event_${event}_plugin"}) {
… …
430# arch as in "arch xxx", ie.. objects 434# arch as in "arch xxx", ie.. objects
431sub normalize_arch($) { 435sub normalize_arch($) {
432 my ($ob) = @_; 436 my ($ob) = @_;
433 437
434 normalize_object $ob; 438 normalize_object $ob;
439
440 return if $ob->{_atype} eq "object";
435 441
436 my $arch = $ARCH{$ob->{_name}} 442 my $arch = $ARCH{$ob->{_name}}
437 or (warn "$ob->{_name}: no such archetype", return $ob); 443 or (warn "$ob->{_name}: no such archetype", return $ob);
438 444
439 if ($arch->{type} == 22) { # map 445 if ($arch->{type} == 22) { # map
… …
475} 481}
476 482
477sub attr_thaw($) { 483sub attr_thaw($) {
478 my ($ob) = @_; 484 my ($ob) = @_;
479 485
480 $ob->{attach} = from_json $ob->{attach} 486 $ob->{attach} = decode_json $ob->{attach}
481 if exists $ob->{attach}; 487 if exists $ob->{attach};
482 488
483 $ob 489 $ob
484} 490}
485 491
486sub attr_freeze($) { 492sub attr_freeze($) {
487 my ($ob) = @_; 493 my ($ob) = @_;
488 494
489 $ob->{attach} = Crossfire::to_json $ob->{attach} 495 $ob->{attach} = JSON::XS->new->utf8->canonical->encode ($ob->{attach})
490 if exists $ob->{attach}; 496 if exists $ob->{attach};
491 497
492 $ob 498 $ob
493} 499}
494 500
… …
514 520
515 my %arc; 521 my %arc;
516 my ($more, $prev); 522 my ($more, $prev);
517 my $comment; 523 my $comment;
518 524
519 open my $fh, "<:raw:perlio:utf8", $path 525 open my $fh, "<:utf8", $path
520 or Carp::croak "$path: $!"; 526 or Carp::croak "$path: $!";
521 527
522# binmode $fh; 528# binmode $fh;
523 529
524 my $parse_block; $parse_block = sub { 530 my $parse_block; $parse_block = sub {
… …
624 my $str; 630 my $str;
625 631
626 my $append; $append = sub { 632 my $append; $append = sub {
627 my %a = %{$_[0]}; 633 my %a = %{$_[0]};
628 634
629 Crossfire::attr_freeze \%a; 635 Deliantra::attr_freeze \%a;
630 Crossfire::normalize_arch \%a; 636 Deliantra::normalize_arch \%a;
631 637
632 # undo the bit-split we did before 638 # undo the bit-split we did before
633 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) { 639 if (exists $a{attack_movement_bits_0_3} or exists $a{attack_movement_bits_4_7}) {
634 $a{attack_movement} = (delete $a{attack_movement_bits_0_3}) 640 $a{attack_movement} = (delete $a{attack_movement_bits_0_3})
635 | (delete $a{attack_movement_bits_4_7}); 641 | (delete $a{attack_movement_bits_4_7});
… …
653 } 659 }
654 660
655 my @kv; 661 my @kv;
656 662
657 for ($a{_name} eq "map" 663 for ($a{_name} eq "map"
658 ? @Crossfire::FIELD_ORDER_MAP 664 ? @Deliantra::FIELD_ORDER_MAP
659 : @Crossfire::FIELD_ORDER) { 665 : @Deliantra::FIELD_ORDER) {
660 push @kv, [$_, delete $a{$_}] 666 push @kv, [$_, delete $a{$_}]
661 if exists $a{$_}; 667 if exists $a{$_};
662 } 668 }
663 669
664 for (sort keys %a) { 670 for (sort keys %a) {
… …
667 } 673 }
668 674
669 for (@kv) { 675 for (@kv) {
670 my ($k, $v) = @$_; 676 my ($k, $v) = @$_;
671 677
672 if (my $end = $Crossfire::FIELD_MULTILINE{$k}) { 678 if (my $end = $Deliantra::FIELD_MULTILINE{$k}) {
673 $v =~ s/\n$//; 679 $v =~ s/\n$//;
674 $str .= "$k\n$v\n$end\n"; 680 $str .= "$k\n$v\n$end\n";
675 } else { 681 } else {
676 $str .= "$k $v\n"; 682 $str .= "$k $v\n";
677 } 683 }
… …
773=cut 779=cut
774 780
775sub arch_attr($) { 781sub arch_attr($) {
776 my ($obj) = @_; 782 my ($obj) = @_;
777 783
778 require Crossfire::Data; 784 require Deliantra::Data;
779 785
780 my $root; 786 my $root;
781 my $attr = { }; 787 my $attr = { };
782 788
783 my $arch = $ARCH{ $obj->{_name} }; 789 my $arch = $ARCH{ $obj->{_name} };
784 my $type = $obj->{type} || $arch->{type}; 790 my $type = $obj->{type} || $arch->{type};
785 791
786 if ($type > 0) { 792 if ($type > 0) {
787 $root = $Crossfire::Data::ATTR{$type}; 793 $root = $Deliantra::Data::ATTR{$type};
788 } else { 794 } else {
789 my %a = (%$arch, %$obj); 795 my %a = (%$arch, %$obj);
790 796
791 if ($a{is_floor} && !$a{alive}) { 797 if ($a{is_floor} && !$a{alive}) {
792 $root = $Crossfire::Data::TYPE{Floor}; 798 $root = $Deliantra::Data::TYPE{Floor};
793 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) { 799 } elsif (!$a{is_floor} && $a{alive} && !$a{tear_down}) {
794 $root = $Crossfire::Data::TYPE{"Monster & NPC"}; 800 $root = $Deliantra::Data::TYPE{"Monster & NPC"};
795 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) { 801 } elsif (!$a{is_floor} && !$a{alive} && $a{move_block}) {
796 $root = $Crossfire::Data::TYPE{Wall}; 802 $root = $Deliantra::Data::TYPE{Wall};
797 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) { 803 } elsif (!$a{is_floor} && $a{alive} && $a{tear_down}) {
798 $root = $Crossfire::Data::TYPE{"Weak Wall"}; 804 $root = $Deliantra::Data::TYPE{"Weak Wall"};
799 } else { 805 } else {
800 $root = $Crossfire::Data::TYPE{Misc}; 806 $root = $Deliantra::Data::TYPE{Misc};
801 } 807 }
802 } 808 }
803 809
804 my @import = ($root); 810 my @import = ($root);
805 811
806 unshift @import, \%Crossfire::Data::DEFAULT_ATTR 812 unshift @import, \%Deliantra::Data::DEFAULT_ATTR
807 unless $type == 116; 813 unless $type == 116;
808 814
809 my (%ignore); 815 my (%ignore);
810 my (@section_order, %section, @attr_order); 816 my (@section_order, %section, @attr_order);
811 817
812 while (my $type = shift @import) { 818 while (my $type = shift @import) {
819 push @import,
820 grep $_,
821 map $Deliantra::Data::TYPE{$_},
813 push @import, @{$type->{import} || []}; 822 @{$type->{import} || []};
814 823
815 $attr->{$_} ||= $type->{$_} 824 $attr->{$_} ||= $type->{$_}
816 for qw(name desc use); 825 for qw(name desc use);
817 826
818 for (@{$type->{ignore} || []}) { 827 for (@{$type->{ignore} || []}) {
… …
943=cut 952=cut
944 953
945sub load_tilecache() { 954sub load_tilecache() {
946 require Gtk2; 955 require Gtk2;
947 956
948 if (-e "$LIB/facedata") { # Crossfire TRT faces
949 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache, 957 cache_file "$LIB/facedata", "$VARDIR/tilecache.pst", \&use_tilecache,
950 sub { 958 sub {
951 my %cache; 959 my %cache;
952 my $facedata = Storable::retrieve "$LIB/facedata"; 960 my $facedata = Storable::retrieve "$LIB/facedata";
953 961
954 $facedata->{version} == 2 962 $facedata->{version} == 2
955 or die "$LIB/facedata: version mismatch, cannot proceed."; 963 or die "$LIB/facedata: version mismatch, cannot proceed.";
956 964
957 my $faces = $facedata->{faceinfo}; 965 my $faces = $facedata->{faceinfo};
958 my $idx = 0; 966 my $idx = 0;
959 967
960 for (sort keys %$faces) { 968 for (sort keys %$faces) {
961 my ($face, $info) = ($_, $faces->{$_}); 969 my ($face, $info) = ($_, $faces->{$_});
962 970
963 my $pb = new Gtk2::Gdk::PixbufLoader; 971 my $pb = new Gtk2::Gdk::PixbufLoader;
964 $pb->write ($info->{data32}); 972 $pb->write ($info->{data32});
965 $pb->close; 973 $pb->close;
966 my $pb = $pb->get_pixbuf; 974 my $pb = $pb->get_pixbuf;
967 975
968 my $tile = $cache{$face} = { 976 my $tile = $cache{$face} = {
969 pb => $pb, 977 pb => $pb,
970 idx => $idx, 978 idx => $idx,
971 w => int $pb->get_width / TILESIZE, 979 w => int $pb->get_width / TILESIZE,
972 h => int $pb->get_height / TILESIZE, 980 h => int $pb->get_height / TILESIZE,
973 }; 981 };
974 982
975 $idx += $tile->{w} * $tile->{h}; 983 $idx += $tile->{w} * $tile->{h};
976 } 984 }
977 985
978 construct_tilecache_pb $idx, \%cache; 986 construct_tilecache_pb $idx, \%cache;
979 987
980 \%cache 988 \%cache
981 }; 989 };
982
983 *FACEDATA = Storable::retrieve "$LIB/facedata";
984
985 } elsif (-e "$LIB/crossfire.0") { # Crossfire1 version
986 cache_file "$LIB/crossfire.0", "$VARDIR/tilecache.pst", \&use_tilecache,
987 sub {
988 my $tile = read_pak "$LIB/crossfire.0";
989
990 my %cache;
991
992 my $idx = 0;
993
994 for my $name (sort keys %$tile) {
995 my $pb = new Gtk2::Gdk::PixbufLoader;
996 $pb->write ($tile->{$name});
997 $pb->close;
998 my $pb = $pb->get_pixbuf;
999
1000 my $tile = $cache{$name} = {
1001 pb => $pb,
1002 idx => $idx,
1003 w => int $pb->get_width / TILESIZE,
1004 h => int $pb->get_height / TILESIZE,
1005 };
1006
1007 $idx += $tile->{w} * $tile->{h};
1008 }
1009
1010 construct_tilecache_pb $idx, \%cache;
1011
1012 \%cache
1013 };
1014
1015 *FACEDATA = { };
1016 }
1017} 990}
1018 991
1019=head1 AUTHOR 992=head1 AUTHOR
1020 993
1021 Marc Lehmann <schmorp@schmorp.de> 994 Marc Lehmann <schmorp@schmorp.de>

Diff Legend

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