ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra/Deliantra.pm
Revision: 1.12
Committed: Thu Feb 9 19:59:29 2006 UTC (18 years, 3 months ago) by root
Branch: MAIN
Changes since 1.11: +2 -121 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 =head1 NAME
2
3 Crossfire - Crossfire maphandling
4
5 =cut
6
7 package Crossfire;
8
9 our $VERSION = '0.1';
10
11 use strict;
12
13 use base 'Exporter';
14
15 use Storable;
16
17 #XXX: The map_* procedures scream for a map-object
18
19 our @EXPORT =
20 qw(read_pak read_arch $ARCH TILESIZE editor_archs
21 arch_extends
22 map_get_tile_stack map_push_tile_stack map_pop_tile_stack
23 );
24
25 our $LIB = $ENV{CROSSFIRE_LIBDIR}
26 or die "\$CROSSFIRE_LIBDIR must be set\n";
27
28 sub TILESIZE (){ 32 }
29
30 our $ARCH;
31
32 sub read_pak($;$) {
33 my ($path, $cache) = @_;
34
35 eval {
36 defined $cache
37 && -M $cache < -M $path
38 && Storable::retrieve $cache
39 } or do {
40 my %pak;
41
42 open my $fh, "<:raw", $path
43 or die "$_[0]: $!";
44 while (<$fh>) {
45 my ($type, $id, $len, $path) = split;
46 $path =~ s/.*\///;
47 read $fh, $pak{$path}, $len;
48 }
49
50 Storable::nstore \%pak, $cache
51 if defined $cache;
52
53 \%pak
54 }
55 }
56
57 sub read_arch($;$) {
58 my ($path, $cache) = @_;
59
60 eval {
61 defined $cache
62 && -M $cache < -M $path
63 && Storable::retrieve $cache
64 } or do {
65 my %arc;
66 my ($more, $prev);
67
68 open my $fh, "<:raw", $path
69 or die "$path: $!";
70
71 my $parse_block; $parse_block = sub {
72 my %arc = @_;
73
74 while (<$fh>) {
75 s/\s+$//;
76 if (/^end$/i) {
77 last;
78 } elsif (/^arch (\S+)$/) {
79 push @{ $arc{inventory} }, $parse_block->(_name => $1);
80 } elsif (/^lore$/) {
81 while (<$fh>) {
82 last if /^endlore\s*$/i;
83 $arc{lore} .= $_;
84 }
85 } elsif (/^msg$/) {
86 while (<$fh>) {
87 last if /^endmsg\s*$/i;
88 $arc{msg} .= $_;
89 }
90 } elsif (/^(\S+)\s*(.*)$/) {
91 $arc{lc $1} = $2;
92 } elsif (/^\s*($|#)/) {
93 #
94 } else {
95 warn "$path: unparsable line '$_' in arch $arc{_name}";
96 }
97 }
98
99 \%arc
100 };
101
102 while (<$fh>) {
103 s/\s+$//;
104 if (/^more$/i) {
105 $more = $prev;
106 } elsif (/^object (\S+)$/i) {
107 my $name = $1;
108 my $arc = $parse_block->(_name => $name);
109
110 if ($more) {
111 $more->{more} = $arc;
112 } else {
113 $arc{$name} = $arc;
114 }
115 $prev = $arc;
116 $more = undef;
117 } elsif (/^arch (\S+)$/i) {
118 push @{ $arc{arch} }, $parse_block->(_name => $1);
119 } elsif (/^\s*($|#)/) {
120 #
121 } else {
122 warn "$path: unparseable top-level line '$_'";
123 }
124 }
125
126 undef $parse_block; # work around bug in perl not freeing $fh etc.
127
128 Storable::nstore \%arc, $cache
129 if defined $cache;
130
131 \%arc
132 }
133 }
134
135 # returns the arch/object stack from a tile on a map
136 sub map_get_tile_stack {
137 my ($map, $x, $y) = @_;
138 my $as;
139
140 if ($x > 0 || $x < $map->{width}
141 || $y > 0 || $y < $map->{height}) {
142
143 $as = $map->{map}{map}[$x][$y] || [];
144 }
145
146 return $as;
147 }
148
149 # pop the topmost arch/object from the stack of a tile on a map
150 sub map_pop_tile_stack {
151 my ($map, $x, $y) = @_;
152
153 if ($x > 0 || $x < $map->{width}
154 || $y > 0 || $y < $map->{height}) {
155
156 pop @{$map->{map}{map}[$x][$y]};
157 }
158 }
159
160 # pushes the arch/object on the stack of a tile on a map
161 sub map_push_tile_stack {
162 my ($map, $x, $y, $arch) = @_;
163
164 if ($x > 0 || $x < $map->{width}
165 || $y > 0 || $y < $map->{height}) {
166
167 push @{$map->{map}{map}[$x][$y]}, $arch;
168 }
169 }
170
171
172 # put all archs into a hash with editor_face as it's key
173 # NOTE: the arrays in the hash values are references to
174 # the archs from $ARCH
175 sub editor_archs {
176 my %paths;
177
178 for (keys %$ARCH) {
179 my $arch = $ARCH->{$_};
180 push @{$paths{$arch->{editor_folder}}}, \$arch;
181 }
182
183 return \%paths;
184 }
185
186 # arch_extends determines how the arch looks like on the map,
187 # bigfaces, linked faces and single faces are handled here
188 # it returns (<xoffset>, <yoffset>, <width>, <height>)
189 # NOTE: non rectangular linked faces are not considered
190 sub arch_extends {
191 my ($a) = @_;
192
193 my $TC = \%Crossfire::Tilecache::TILECACHE;
194
195 my $facename =
196 $a->{face} || $ARCH->{$a->{_name}}->{face}
197 or return ();
198
199 my $tile = $TC->{$facename}
200 or (warn "no gfx found for arch '$facename' in arch_size ()"), return;
201
202 if ($tile->{w} > 1 || $tile->{h} > 1) {
203 # bigfaces
204 return (0, 0, $tile->{w}, $tile->{h});
205
206 } elsif ($a->{more}) {
207 # linked faces
208 my ($miw, $mih, $maw, $mah) = (0, 0, 0, 0);
209 do {
210 $miw > (0 + $a->{x}) and $miw = $a->{x};
211 $mih > (0 + $a->{y}) and $mih = $a->{y};
212 $maw < (0 + $a->{x}) and $maw = $a->{x};
213 $mah < (0 + $a->{y}) and $mah = $a->{y};
214 } while $a = $a->{more};
215
216 return ($miw, $mih, ($maw - $miw) + 1, ($mah - $mih) + 1)
217
218 } else {
219 # single face
220 return (0, 0, 1, 1);
221 }
222 }
223
224 sub init($) {
225 my ($cachedir) = @_;
226
227 $ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
228 }
229
230 =head1 AUTHOR
231
232 Marc Lehmann <schmorp@schmorp.de>
233 http://home.schmorp.de/
234
235 Robin Redeker <elmex@ta-sa.org>
236 http://www.ta-sa.org/
237
238 =cut
239
240 1