1 |
#!/opt/bin/perl |
2 |
|
3 |
# read through the whole maps at .=/ and replace all exits by |
4 |
# tags that point to one of the maps given on the commandline |
5 |
# (which must be relative paths starting at .!) |
6 |
|
7 |
use common::sense; |
8 |
|
9 |
use Deliantra; |
10 |
use Deliantra::Map; |
11 |
use Tie::Cache; |
12 |
use Errno; |
13 |
|
14 |
{ |
15 |
package mapcache; |
16 |
|
17 |
use base Tie::Cache::; |
18 |
|
19 |
sub read { |
20 |
my $map = eval { |
21 |
new_from_file Deliantra::Map $_[1] |
22 |
}; |
23 |
|
24 |
if ($@) { |
25 |
die unless $@ =~ /No such file or directory/; |
26 |
warn $@; |
27 |
} |
28 |
|
29 |
$map |
30 |
|
31 |
} |
32 |
|
33 |
sub write { |
34 |
my ($self, $path, $map) = @_; |
35 |
$map or return; |
36 |
warn "writing $path\n";#d# |
37 |
$map->write_file ($path); |
38 |
} |
39 |
} |
40 |
|
41 |
our %map; |
42 |
tie %map, mapcache::, 100, { Debug => 0, WriteSync => 0 } |
43 |
or die; |
44 |
|
45 |
Deliantra::load_archetypes; |
46 |
|
47 |
sub expand { |
48 |
my ($path, $base) = @_; |
49 |
|
50 |
$path =~ s/\.map$//; |
51 |
|
52 |
return +(substr $path, 1) . ".map" if $path =~ /^\//; |
53 |
|
54 |
defined $base |
55 |
or die "relative path without base"; |
56 |
|
57 |
$path = "$base/../$path.map"; |
58 |
|
59 |
1 while $path =~ s/\/+[^\/]*\/+\.\./\//; |
60 |
1 while $path =~ s/\/\//\//; |
61 |
|
62 |
$path |
63 |
} |
64 |
|
65 |
my %is_exit = ( 41 => 1, 57 => 1, 66 => 1 ); |
66 |
|
67 |
sub gen_tag { |
68 |
my ($path, $suffix, $x, $y) = @_; |
69 |
|
70 |
# create a tag name |
71 |
my $tag = $path; |
72 |
$tag =~ s/\.map$//; |
73 |
$tag =~ s/\//_/g; |
74 |
$tag .= $suffix; |
75 |
$tag .= $x <= 0 || $y <= 0 ? "_entrance" : "+${x}+${y}"; |
76 |
|
77 |
1 while $tag =~ s/\b([^_]+)_\1\b/$1/; |
78 |
|
79 |
lc $tag |
80 |
} |
81 |
|
82 |
sub patch_exit { |
83 |
my ($from, $fx, $fy, $path, $x, $y) = @_; |
84 |
|
85 |
my $map = $map{$path} |
86 |
or return; |
87 |
|
88 |
my $tag; |
89 |
|
90 |
my $tag = |
91 |
$path =~ /world/ && $from !~ /world/ |
92 |
? gen_tag $from, "_exit", $fx, $fy |
93 |
: gen_tag $path, "", $x, $y; |
94 |
|
95 |
$x = $map->{info}{enter_x} if $x <= 0; |
96 |
$y = $map->{info}{enter_y} if $y <= 0; |
97 |
|
98 |
$x >= 0 && $y >= 0 |
99 |
or ((warn "invalid x,y"), return); |
100 |
|
101 |
# 1. try to find an existing tag |
102 |
my $os = $map->{map}[$x][$y] ||= []; |
103 |
if (my ($tagged) = grep exists $_->{tag}, @$os) { |
104 |
return $tagged->{tag}; |
105 |
} |
106 |
|
107 |
# 2. find an existing exit |
108 |
if (my ($exit) = grep $is_exit{$_->{type} || $ARCH{$_->{_name}}{type}}, @$os) { |
109 |
$exit->{tag} = $tag; |
110 |
$map{$path} = $map; |
111 |
return $tag; |
112 |
} |
113 |
|
114 |
# 3. add a tag object to the bottom |
115 |
unshift @$os, { _atype => "arch", _name => "tag", tag => $tag }; |
116 |
$map{$path} = $map; |
117 |
$tag |
118 |
} |
119 |
|
120 |
open my $fh, "find * -name '*.map' -type f -print0 |" |
121 |
or die "find: $!"; |
122 |
|
123 |
my %target; |
124 |
|
125 |
for (@ARGV) { |
126 |
s/\.map$//; |
127 |
s/^\///; |
128 |
s/\/\/+/\//g; |
129 |
$_ .= ".map"; |
130 |
|
131 |
$target{$_} = 1; |
132 |
} |
133 |
|
134 |
while (defined (my $path = do { local $/ = "\x00"; <$fh> })) { |
135 |
chop $path; |
136 |
my $map = $map{$path}; |
137 |
|
138 |
for my $fx (0 .. $map->{info}{width} - 1) { |
139 |
for my $fy (0 .. $map->{info}{height} - 1) { |
140 |
my $space = $map->{map}[$fx][$fy] |
141 |
or next; |
142 |
|
143 |
for my $o (@$space) { |
144 |
my $a = $Deliantra::ARCH{$o->{_name}} |
145 |
or next; |
146 |
|
147 |
if ($is_exit{$o->{type} || $a->{type}}) { |
148 |
my ($exit, $x, $y) = ($o->{slaying}, $o->{hp}, $o->{sp}); |
149 |
if ($exit =~ /^[\/0-9a-zA-Z\.]/ && $exit ne "/!") { |
150 |
$exit = expand $exit, $path; |
151 |
if ($exit ne $path && $target{$exit}) { |
152 |
if (my $tag = patch_exit $path, $fx, $fy, $exit, $x, $y) { |
153 |
delete $o->{sp}; |
154 |
delete $o->{hp}; |
155 |
$o->{slaying} = "*$tag"; |
156 |
$map{$path} = $map; |
157 |
|
158 |
warn "$path: found exit $exit $x $y => *$tag\n";#d# |
159 |
} else { |
160 |
warn "$path: $exit $o->{hp} $o->{sp} unpatchable\n"; |
161 |
} |
162 |
} |
163 |
} |
164 |
} |
165 |
} |
166 |
} |
167 |
} |
168 |
} |
169 |
|
170 |
%map = (); |
171 |
|