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.3 by elmex, Sat Feb 4 23:56:14 2006 UTC vs.
Revision 1.10 by elmex, Mon Feb 6 23:01:31 2006 UTC

1=head1 NAME
2
3Crossfire - Crossfire maphandling
4
5=cut
6
1package Crossfire; 7package Crossfire;
2=head1 NAME
3
4Crossfire - Crossfire maphandling
5
6=cut
7 8
8our $VERSION = '0.1'; 9our $VERSION = '0.1';
9 10
10use strict; 11use strict;
11 12
13use base 'Exporter';
14
12use Storable; 15use Storable;
13use List::Util qw(max);
14 16
15#use Gtk2; 17our @EXPORT = qw(read_pak read_arch arch2map $ARCH TILESIZE editor_archs arch2pickmap arch_extends);
16 18
17#init Gtk2::Gdk;
18
19my $LIB = $ENV{CROSSFIRE_LIBDIR} 19our $LIB = $ENV{CROSSFIRE_LIBDIR}
20 or die "\$CROSSFIRE_LIBDIR must be set\n"; 20 or die "\$CROSSFIRE_LIBDIR must be set\n";
21 21
22my $VARDIR = "$ENV{HOME}/.gcfedit";
23mkdir $VARDIR;
24
25sub T (){ 32 } 22sub TILESIZE (){ 32 }
26 23
24our $ARCH;
25
27sub read_pak($) { 26sub read_pak($;$) {
28 my ($path) = @_; 27 my ($path, $cache) = @_;
29 28
30 eval { 29 eval {
31 -M "$VARDIR/crossfire.pak.pst" < -M $path 30 defined $cache
32 && Storable::retrieve "$VARDIR/crossfire.pak.pst" 31 && -M $cache < -M $path
32 && Storable::retrieve $cache
33 } or do { 33 } or do {
34 my %pak; 34 my %pak;
35 35
36 open my $fh, "<:raw", $path 36 open my $fh, "<:raw", $path
37 or die "$_[0]: $!"; 37 or die "$_[0]: $!";
… …
39 my ($type, $id, $len, $path) = split; 39 my ($type, $id, $len, $path) = split;
40 $path =~ s/.*\///; 40 $path =~ s/.*\///;
41 read $fh, $pak{$path}, $len; 41 read $fh, $pak{$path}, $len;
42 } 42 }
43 43
44 Storable::nstore \%pak, "$VARDIR/crossfire.pak.pst"; 44 Storable::nstore \%pak, $cache
45 if defined $cache;
45 46
46 \%pak 47 \%pak
47 } 48 }
48} 49}
49 50
50sub read_arch($;$) { 51sub read_arch($;$) {
51 my ($path) = @_; 52 my ($path, $cache) = @_;
52 53
54 eval {
55 defined $cache
56 && -M $cache < -M $path
57 && Storable::retrieve $cache
58 } or do {
53 my %arc; 59 my %arc;
54 my ($more, $prev); 60 my ($more, $prev);
55 61
56 open my $fh, "<:raw", $path 62 open my $fh, "<:raw", $path
57 or die "$path: $!"; 63 or die "$path: $!";
58 64
59 my $parse_block; $parse_block = sub { 65 my $parse_block; $parse_block = sub {
60 my %arc = @_; 66 my %arc = @_;
67
68 while (<$fh>) {
69 s/\s+$//;
70 if (/^end$/i) {
71 last;
72 } elsif (/^arch (\S+)$/) {
73 push @{ $arc{inventory} }, $parse_block->(_name => $1);
74 } elsif (/^lore$/) {
75 while (<$fh>) {
76 last if /^endlore\s*$/i;
77 $arc{lore} .= $_;
78 }
79 } elsif (/^msg$/) {
80 while (<$fh>) {
81 last if /^endmsg\s*$/i;
82 $arc{msg} .= $_;
83 }
84 } elsif (/^(\S+)\s*(.*)$/) {
85 $arc{lc $1} = $2;
86 } elsif (/^\s*($|#)/) {
87 #
88 } else {
89 warn "$path: unparsable line '$_' in arch $arc{_name}";
90 }
91 }
92
93 \%arc
94 };
61 95
62 while (<$fh>) { 96 while (<$fh>) {
63 s/\s+$//; 97 s/\s+$//;
64 if (/^end$/i) { 98 if (/^more$/i) {
65 last; 99 $more = $prev;
66 } elsif (/^arch (\S+)$/) { 100 } elsif (/^object (\S+)$/i) {
101 my $name = $1;
67 push @{ $arc{inventory} }, $parse_block->(_name => $1); 102 my $arc = $parse_block->(_name => $name);
68 } elsif (/^lore$/) { 103
69 while (<$fh>) { 104 if ($more) {
70 last if /^endlore\s*$/i; 105 $more->{more} = $arc;
106 } else {
71 $arc{lore} .= $_; 107 $arc{$name} = $arc;
72 } 108 }
73 } elsif (/^msg$/) { 109 $prev = $arc;
74 while (<$fh>) { 110 $more = undef;
75 last if /^endmsg\s*$/i;
76 $arc{msg} .= $_;
77 }
78 } elsif (/^(\S+)\s*(.*)$/) { 111 } elsif (/^arch (\S+)$/i) {
79 $arc{lc $1} = $2; 112 push @{ $arc{arch} }, $parse_block->(_name => $1);
80 } elsif (/^\s*($|#)/) { 113 } elsif (/^\s*($|#)/) {
81 # 114 #
82 } else { 115 } else {
83 warn "$path: unparsable line '$_' in arch $arc{_name}"; 116 warn "$path: unparseable top-level line '$_'";
84 } 117 }
85 } 118 }
86 119
120 undef $parse_block; # work around bug in perl not freeing $fh etc.
121
122 Storable::nstore \%arc, $cache
123 if defined $cache;
124
87 \%arc 125 \%arc
88 }; 126 }
127}
89 128
90 while (<$fh>) { 129# put all archs into a hash with editor_face as it's key
91 s/\s+$//; 130# NOTE: the arrays in the hash values are references to
92 if (/^more$/i) { 131# the archs from $ARCH
93 $more = $prev; 132sub editor_archs {
94 } elsif (/^object (\S+)$/i) { 133 my %paths;
95 my $name = $1;
96 my $arc = $parse_block->(_name => $name);
97 134
98 if ($more) { 135 for (keys %$ARCH) {
99 $more->{more} = $arc; 136 my $arch = $ARCH->{$_};
137 push @{$paths{$arch->{editor_folder}}}, \$arch;
138 }
139
140 return \%paths;
141}
142
143# arch_extends determines how the arch looks like on the map,
144# bigfaces, linked faces and single faces are handled here
145# it returns (<xoffset>, <yoffset>, <width>, <height>)
146# NOTE: non rectangular linked faces are not considered
147sub arch_extends {
148 my ($a) = @_;
149
150 my $TC = \%Crossfire::Tilecache::TILECACHE;
151
152 my $facename =
153 $a->{face} || $ARCH->{$a->{_name}}->{face}
154 or return ();
155
156 my $tile = $TC->{$facename}
157 or (warn "no gfx found for arch '$facename' in arch_size ()"), return;
158
159 if ($tile->{w} > 1 || $tile->{h} > 1) {
160 # bigfaces
161 return (0, 0, $tile->{w}, $tile->{h});
162
163 } elsif ($a->{more}) {
164 # linked faces
165 my ($miw, $mih, $maw, $mah) = (0, 0, 0, 0);
166 do {
167 $miw > (0 + $a->{x}) and $miw = $a->{x};
168 $mih > (0 + $a->{y}) and $mih = $a->{y};
169 $maw < (0 + $a->{x}) and $maw = $a->{x};
170 $mah < (0 + $a->{y}) and $mah = $a->{y};
171 } while $a = $a->{more};
172
173 return ($miw, $mih, ($maw - $miw) + 1, ($mah - $mih) + 1)
174
175 } else {
176 # single face
177 return (0, 0, 1, 1);
178 }
179}
180
181# arch2pickmap forms a list of archs to a pickmap
182sub arch2pickmap {
183 my ($archs, $w) = @_;
184
185 # sort archs alphabetiacally
186 my $archs = [ sort { ${$a}->{_name} cmp ${$b}->{_name} } @$archs ];
187
188 $w ||= 10; # default width
189 my $num = @$archs;
190 my $map = { };
191 # overall placement coords
192 my $x = 0;
193 my $y = 0;
194
195 my ($maxh, $maxw) = (0, 0); # maximum sizes, to set map width/height later
196 my $drawn_archs = 1; # line-break counter
197 my $max_line_height = 1;
198
199 for (my $i = 0; $i < $num; $i++) {
200
201 defined ${$archs->[$i]}->{face} or next;
202
203 # check whether this tile was already written (see below at (b))
204 unless (defined $map->{map}[$x][$y]) {
205
206 my ($xoffs, $yoffs, $arch_w, $arch_h) = arch_extends (${$archs->[$i]});
207
208 # these are special placement coords, for chained faces which
209 # have a special placement offset
210 my ($place_x, $place_y) = ($x, $y);
211 $xoffs < 0 and
212 $place_x += -$xoffs;
213 $yoffs < 0 and
214 $place_y += -$yoffs;
215
216 # iterate over the tiles this arch takes
217 # NOTE: Chained archs are maybe not a rectangle, but i don't care
218 # much for that on pickmaps
219
220 for (my $xi = 0; $xi < $arch_w; $xi++) {
221 for (my $yi = 0; $yi < $arch_h; $yi++) {
222
223 my ($lx, $ly) = ($x + $xi, $y + $yi);
224
225 if ($lx == $place_x and $ly == $place_y) {
226 push @{$map->{map}[$place_x][$place_y]}, my $a = ${$archs->[$i]};
227
100 } else { 228 } else {
101 $arc{$name} = $arc; 229
230 # (b): here we set occupied tiles, but without the arch
231 $map->{map}[$lx][$ly] = [];
232 }
233 }
102 } 234 }
103 $prev = $arc; 235 $drawn_archs++;
104 $more = undef; 236
105 } elsif (/^arch (\S+)$/i) { 237 $x += $arch_w - 1;
106 push @{ $arc{arch} }, $parse_block->(_name => $1); 238 $max_line_height < $arch_h
107 } elsif (/^\s*($|#)/) { 239 and $max_line_height = $arch_h;
108 # 240
109 } else { 241 } else {
110 warn "$path: unparseable top-level line '$_'"; 242 $i--;
111 } 243 }
112 }
113 244
114 undef $parse_block; # work around bug in perl not freeing $fh etc.
115 245
116 \%arc 246 $x++;
117}
118 247
248 if ($x > $w) {
249
250 $y += $max_line_height;
251 $max_line_height = 1;
252 $x = 0;
253 }
254
255 $maxw < ($x + 1) and $maxw = $x + 1;
256 $maxh < ($y + 1) and $maxh = $y + 1;
257 }
258
259 $map->{height} = $maxh;
260 $map->{width} = $maxw;
261
262 return $map;
263}
264
119sub cfmap_meta($;$) { 265sub arch2map($;$) {
120 my ($self, $mapa, $mapname) = @_; 266 my ($mapa) = @_;
121
122 my $arch = $self->{arch};
123 267
124 my %meta; 268 my %meta;
125 269
126 my ($mapx, $mapy); 270 my ($mapx, $mapy);
127 271
128 my $map; 272 my $map;
129 273
130 for (@{ $mapa->{arch} }) { 274 for (@{ $mapa->{arch} }) {
131 my ($x, $y) = ($_->{x}, $_->{y}); 275 my ($x, $y) = (delete $_->{x}, delete $_->{y});
132 276
133 if ($_->{_name} eq "map") { 277 if ($_->{_name} eq "map") {
134 $meta{info} = $_; 278 $meta{info} = $_;
135 279
136 $mapx = $_->{width} || $x; 280 $mapx = $_->{width} || $x;
… …
146 } 290 }
147 } 291 }
148 292
149 $meta{width} = $mapx; 293 $meta{width} = $mapx;
150 $meta{height} = $mapy; 294 $meta{height} = $mapy;
151 295 $meta{map} = $map;
152 my %draw_info;
153 my %map_info;
154
155 # first pass, gather face stacking order, border and corner info
156 for my $x (0 .. $mapx - 1) {
157 my $col = $map->[$x];
158 for my $y (0 .. $mapy - 1) {
159 my $as = $col->[$y] || [];
160
161 for my $layer (0 .. $#$as) {
162 my $a = $as->[$layer];
163
164 my $o = $arch->{$a->{_name}}
165 or (warn "$mapname: arch '$a->{_name}' not found at ($x|$y)\n"), next;
166
167 #my $is_floor = exists $a->{is_floor} ? $a->{is_floor} : $o->{is_floor};
168 my $level = $layer * 256;
169
170 $level -= 100 * 256 if $o->{_name} eq "blocked";
171
172 while ($o) {
173 my $face = $a->{face} || $o->{face};
174
175 my $mx = $x + $o->{x};
176 my $my = $y + $o->{y};
177
178 last if 0 > $mx || $mx >= $mapx
179 || 0 > $my || $my >= $mapy;
180
181 push @{ $map_info{$level}{$mx, $my} }, $a;
182
183 $o = $o->{more};
184 $level = ($layer + 1000) * 2; # put "big things" on top, no matter what
185 }
186 }
187 }
188 }
189
190 # third pass, gather meta info
191 for my $level (sort { $a <=> $b } keys %map_info) {
192 my $info = $map_info{$level};
193
194 while (my ($xy, $as) = each %$info) {
195 my ($x, $y) = split $;, $xy;
196
197 next if $x < 0 || $x >= $mapx
198 || $y < 0 || $y >= $mapy;
199
200 push @{ $meta{map}[$x][$y] }, $_ for @$as;
201 }
202 }
203 296
204 \%meta 297 \%meta
205} 298}
206 299
207sub new { 300sub init($) {
208 my $class = shift; 301 my ($cachedir) = @_;
209 my $self = bless { }, $class;
210 $self->{arch} = read_arch "$LIB/archetypes";
211 $self->{tile} = read_pak "$LIB/crossfire.0";
212 $self
213}
214 302
215sub read { 303 $ARCH = read_arch "$LIB/archetypes", "$cachedir/archetypes.pst";
216 my ($self, $file) = @_;
217 my $mapa = read_arch $file;
218 my $map = $self->cfmap_meta ($mapa, $file);
219 print "READ: ".join(',', %{$map->{info}})."\n";
220 return $map;
221} 304}
222 305
223=head1 AUTHOR 306=head1 AUTHOR
224 307
225 Marc Lehmann <schmorp@schmorp.de> 308 Marc Lehmann <schmorp@schmorp.de>
… …
227 310
228 Robin Redeker <elmex@ta-sa.org> 311 Robin Redeker <elmex@ta-sa.org>
229 http://www.ta-sa.org/ 312 http://www.ta-sa.org/
230 313
231=cut 314=cut
2321; 315
3161

Diff Legend

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