Move all other sources in a separate subfolder
[voretournament/voretournament.git] / misc / tools / bsptool.pl
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5 use Image::Magick;
6 use POSIX qw/floor ceil/;
7
8 my @lumpname = qw/entities textures planes nodes leafs leaffaces leafbrushes models brushes brushsides vertices triangles effects faces lightmaps lightgrid pvs advertisements/;
9 my %lumpid = map { $lumpname[$_] => $_ } 0..@lumpname-1;
10 my $msg = "";
11 my @bsp;
12
13 # READ THE BSP
14
15 if(!@ARGV || $ARGV[0] eq '-h' || $ARGV[0] eq '--help')
16 {
17         print <<EOF;
18 Usage:
19   $0 filename.bsp [operations...]
20
21 Operations are:
22   Information requests:
23     -i                print info about the BSP file
24     -xlumpname        extract a lump (see -i)
25
26   Changes:
27     -dlumpname        delete a lump (see -i)
28     -rlumpname        replace a lump (see -i) by the data from standard input
29     -gfilename.tga    save the lightgrid as filename.tga (debugging)
30     -Gratio           scale down the lightgrid to reduce BSP file size
31     -ljpgNNN          externalize the lightmaps as JPEG, quality NNN (number from 1 to 100)
32     -lpng             externalize the lightmaps as PNG
33     -ltga             externalize the lightmaps as TGA
34     -mMESSAGE         set the BSP file comment message
35
36   Save commands:
37     -o                actually apply the changes to the BSP
38     -ofilename2.bsp   save the changes to a new BSP file
39 EOF
40         exit;
41 }
42
43 my $fn = shift @ARGV;
44 $fn =~ /(.*)\.bsp$/
45         or die "invalid input file name (must be a .bsp): $fn";
46 my $basename = $1;
47 open my $fh, "<", $fn
48         or die "$fn: $!";
49
50 read $fh, my $header, 8;
51
52 die "Invalid BSP format"
53         if $header ne "IBSP\x2e\x00\x00\x00";
54
55 for(0..16)
56 {
57         read $fh, my $lump, 8;
58         my ($offset, $length) = unpack "VV", $lump;
59
60         push @bsp, [$offset, $length, undef];
61 }
62
63 for(@bsp)
64 {
65         my ($offset, $length, $data) = @$_;
66         seek $fh, $offset, 0;
67         read $fh, $data, $length;
68         length $data == $length
69                 or die "Incomplete BSP lump at $offset\n";
70         $_->[2] = $data;
71 }
72
73 close $fh;
74
75 # STRUCT DECODING
76
77 sub DecodeLump($@)
78 {
79         my ($lump, @fields) = @_;
80         my @decoded;
81
82         my $spec = "";
83         my @decoders;
84
85         my $item;
86         my @data;
87         my $idx;
88
89         for(@fields)
90         {
91                 if(/^(\w*)=(.*?)(\d*)$/)
92                 {
93                         $spec .= "$2$3 ";
94                         my $f = $1;
95                         my $n = $3;
96                         if($n eq '')
97                         {
98                                 push @decoders, sub { $item->{$f} = $data[$idx++]; };
99                         }
100                         else
101                         {
102                                 push @decoders, sub { $item->{$f} = [ map { $data[$idx++] } 1..$n ]; };
103                         }
104                 }
105         }
106
107         my $itemlen = length pack $spec, ();
108         my $len = length $lump;
109
110         die "Invalid lump size: $len not divisible by $itemlen"
111                 if $len % $itemlen;
112
113         my $items = $len / $itemlen;
114         for(0..$items - 1)
115         {
116                 @data = unpack $spec, substr $lump, $_ * $itemlen, $itemlen;
117                 $item = {};
118                 $idx = 0;
119                 $_->() for @decoders;
120                 push @decoded, $item;
121         }
122         @decoded;
123 }
124
125 sub EncodeLump($@)
126 {
127         my ($items, @fields) = @_;
128         my @decoded;
129
130         my @encoders;
131
132         my $item;
133         my @data;
134         my $idx;
135         my $data = "";
136
137         for(@fields)
138         {
139                 if(/^(\w*)=(.*?)(\d*)$/)
140                 {
141                         my $spec = "$2$3";
142                         my $f = $1;
143                         my $n = $3;
144                         if($n eq '')
145                         {
146                                 push @encoders, sub { $data .= pack $spec, $item->{$f}; };
147                         }
148                         else
149                         {
150                                 push @encoders, sub { $data .= pack $spec, @{$item->{$f}}; };
151                         }
152                 }
153         }
154
155         for my $i(@$items)
156         {
157                 $item = $i;
158                 $_->() for @encoders;
159         }
160
161         $data;
162 }
163
164 sub EncodeDirection(@)
165 {
166         my ($x, $y, $z) = @_;
167
168         return [
169                 map { ($_ / 0.02454369260617025967) & 0xFF }
170                 (
171                         atan2(sqrt($x * $x + $y * $y), $z),
172                         atan2($y, $x)
173                 )
174         ];
175 }
176
177 sub DecodeDirection($)
178 {
179         my ($dir) = @_;
180
181         my ($pitch, $yaw) = map { $_ * 0.02454369260617025967 } @$dir; # maps 256 to 2pi
182
183         return (
184                 cos($yaw) * sin($pitch),
185                 sin($yaw) * sin($pitch),
186                 cos($pitch)
187         );
188 }
189
190 sub IntervalIntersection($$$$)
191 {
192         my ($a, $al, $b, $bl) = @_;
193         my $a0 = $a - 0.5 * $al;
194         my $a1 = $a + 0.5 * $al;
195         my $b0 = $b - 0.5 * $bl;
196         my $b1 = $b + 0.5 * $bl;
197         my $left = ($a0 > $b0) ? $a0 : $b0;
198         my $right = ($a1 > $b1) ? $b1 : $a1;
199         die "Non-intersecting intervals $a $al $b $bl"
200                 if $right < $left;
201         return $right - $left;
202 }
203
204 sub BoxIntersection(@)
205 {
206         my ($x, $y, $z, $w, $h, $d, $x2, $y2, $z2, $w2, $h2, $d2) = @_;
207         return
208                 IntervalIntersection($x, $w, $x2, $w2)
209                 *
210                 IntervalIntersection($y, $h, $y2, $h2)
211                 *
212                 IntervalIntersection($z, $d, $z2, $d2);
213 }
214
215 # OPTIONS
216
217 for(@ARGV)
218 {
219         if(/^-i$/) # info
220         {
221                 my $total = 17 * 8 + 8 + length($msg);
222                 my $max = 0;
223                 for(0..@bsp-1)
224                 {
225                         my $nl = length $bsp[$_]->[2];
226                         $total += $nl;
227                         print "BSP lump $_ ($lumpname[$_]): offset $bsp[$_]->[0] length $bsp[$_]->[1] newlength $nl\n";
228                         my $endpos = $bsp[$_]->[0] + $bsp[$_]->[1];
229                         $max = $endpos if $max < $endpos;
230                 }
231                 print "BSP file size will change from $max to $total bytes\n";
232         }
233         elsif(/^-d(.+)$/) # delete a lump
234         {
235                 my $id = $lumpid{$1};
236                 die "invalid lump $1 to remove"
237                         unless defined $id;
238                 $bsp[$id]->[2] = "";
239         }
240         elsif(/^-r(.+)$/) # replace a lump
241         {
242                 my $id = $lumpid{$1};
243                 die "invalid lump $1 to replace"
244                         unless defined $id;
245                 $bsp[$id]->[2] = do { undef local $/; scalar <STDIN>; };
246         }
247         elsif(/^-m(.*)$/) # change the message
248         {
249                 $msg = $1;
250         }
251         elsif(/^-l(jpg|png|tga)(\d+)?$/) # externalize lightmaps (deleting the internal ones)
252         {
253                 my $ext = $1;
254                 my $quality = $2;
255                 my %lightmaps = ();
256                 my $faces = $bsp[$lumpid{faces}]->[2];
257                 my $lightmaps = $bsp[$lumpid{lightmaps}]->[2];
258                 my @values = DecodeLump $faces,
259                         qw/texture=V effect=V type=V vertex=V n_vertexes=V meshvert=V n_meshverts=V lm_index=V lm_start=f2 lm_size=f2 lm_origin=f3 lm_vec_0=f3 lm_vec_1=f3 normal=f3 size=V2/;
260                 my $oddfound = 0;
261                 for(@values)
262                 {
263                         my $l = $_->{lm_index};
264                         next if $l >= 2**31; # signed
265                         $oddfound = 1
266                                 if $l % 2;
267                         ++$lightmaps{$l};
268                 }
269                 if(!$oddfound)
270                 {
271                         $lightmaps{$_+1} = $lightmaps{$_} for keys %lightmaps;
272                 }
273                 for(sort { $a <=> $b } keys %lightmaps)
274                 {
275                         print STDERR "Lightmap $_ was used $lightmaps{$_} times\n";
276
277                         # export that lightmap
278                         my $lmsize = 128 * 128 * 3;
279                         next if length $lightmaps < ($_ + 1) * $lmsize;
280                         my $lmdata = substr $lightmaps, $_ * $lmsize, $lmsize;
281                         my $img = Image::Magick->new(size => '128x128', depth => 8, magick => 'RGB');
282                         $img->BlobToImage($lmdata);
283                         my $outfn = sprintf "%s/lm_%04d.$ext", $basename, $_;
284                         mkdir $basename;
285                         $img->Set(quality => $quality)
286                                 if defined $quality;
287                         my $err = $img->Write($outfn);
288                         die $err
289                                 if $err;
290                         print STDERR "Wrote $outfn\n";
291                 }
292
293                 # nullify the lightmap lump
294                 $bsp[$lumpid{lightmaps}]->[2] = "";
295         }
296         elsif(/^-g(.+)$/) # export light grid as an image (for debugging)
297         {
298                 my $filename = $1;
299                 my @models = DecodeLump $bsp[$lumpid{models}]->[2],
300                         qw/mins=f3 maxs=f3 face=V n_faces=V brush=V n_brushes=V/;
301                 my $entities = $bsp[$lumpid{entities}]->[2];
302                 my @entitylines = split /\r?\n/, $entities;
303                 my $gridsize = "64 64 128";
304                 for(@entitylines)
305                 {
306                         last if $_ eq '}';
307                         /^\s*"_?gridsize"\s+"(.*)"$/
308                                 and $gridsize = $1;
309                 }
310                 my @scale = map { 1 / $_ } split / /, $gridsize;
311                 my @imins = map { ceil($models[0]{mins}[$_] * $scale[$_]) } 0..2;
312                 my @imaxs = map { floor($models[0]{maxs}[$_] * $scale[$_]) } 0..2;
313                 my @isize = map { $imaxs[$_] - $imins[$_] + 1 } 0..2;
314                 my $isize = $isize[0] * $isize[1] * $isize[2];
315                 my @gridcells = DecodeLump $bsp[$lumpid{lightgrid}]->[2],
316                         qw/ambient=C3 directional=C3 dir=C2/;
317                 die "Cannot decode light grid"
318                         unless $isize == @gridcells;
319
320                 # sum up the "ambient" light over all pixels
321                 my @pixels;
322                 my $max = 1;
323                 for my $y(0..$isize[1]-1)
324                 {
325                         for my $x(0..$isize[0]-1)
326                         {
327                                 my ($r, $g, $b) = (0, 0, 0);
328                                 for my $z(0..$isize[2]-1)
329                                 {
330                                         my $cell = $gridcells[$x + $y * $isize[0] + $z * $isize[0] * $isize[1]];
331                                         $r += $cell->{ambient}->[0];
332                                         $g += $cell->{ambient}->[1];
333                                         $b += $cell->{ambient}->[2];
334                                 }
335                                 push @pixels, [$r, $g, $b];
336                                 $max = $r if $max < $r;
337                                 $max = $g if $max < $g;
338                                 $max = $b if $max < $b;
339                         }
340                 }
341                 my $pixeldata = "";
342                 for my $p(@pixels)
343                 {
344                         $pixeldata .= pack "CCC", map { 255 * $p->[$_] / $max } 0..2;
345                 }
346
347                 my $img = Image::Magick->new(size => sprintf("%dx%d", $isize[0], $isize[1]), depth => 8, magick => 'RGB');
348                 $img->BlobToImage($pixeldata);
349                 $img->Write($filename);
350                 print STDERR "Wrote $filename\n";
351         }
352         elsif(/^-G(.+)$/) # decimate light grid
353         {
354                 my $decimate = $1;
355                 my $filter = 1; # 0 = nearest, 1 = box filter
356
357                 my @models = DecodeLump $bsp[$lumpid{models}]->[2],
358                         qw/mins=f3 maxs=f3 face=V n_faces=V brush=V n_brushes=V/;
359                 my $entities = $bsp[$lumpid{entities}]->[2];
360                 my @entitylines = split /\r?\n/, $entities;
361                 my $gridsize = "64 64 128";
362                 my $gridsizeindex = undef;
363                 for(0..@entitylines-1)
364                 {
365                         my $l = $entitylines[$_];
366                         last if $l eq '}';
367                         if($l =~ /^\s*"_?gridsize"\s+"(.*)"$/)
368                         {
369                                 $gridsize = $1;
370                                 $gridsizeindex = $_;
371                         }
372                 }
373                 my @scale = map { 1 / $_ } split / /, $gridsize;
374                 my @imins = map { ceil($models[0]{mins}[$_] * $scale[$_]) } 0..2;
375                 my @imaxs = map { floor($models[0]{maxs}[$_] * $scale[$_]) } 0..2;
376                 my @isize = map { $imaxs[$_] - $imins[$_] + 1 } 0..2;
377                 my $isize = $isize[0] * $isize[1] * $isize[2];
378                 my @gridcells = DecodeLump $bsp[$lumpid{lightgrid}]->[2],
379                         qw/ambient=C3 directional=C3 dir=C2/;
380                 die "Cannot decode light grid"
381                         unless $isize == @gridcells;
382
383                 # get the new grid size values
384                 my @newscale = map { $_ / $decimate } @scale;
385                 my $newgridsize = join " ", map { 1 / $_ } @newscale;
386                 my @newimins = map { ceil($models[0]{mins}[$_] * $newscale[$_]) } 0..2;
387                 my @newimaxs = map { floor($models[0]{maxs}[$_] * $newscale[$_]) } 0..2;
388                 my @newisize = map { $newimaxs[$_] - $newimins[$_] + 1 } 0..2;
389
390                 # do the decimation
391                 my @newgridcells = ();
392                 for my $z($newimins[2]..$newimaxs[2])
393                 {
394                         # the coords are MIDPOINTS of the grid cells!
395                         my @oldz = grep { $_ >= $imins[2] && $_ <= $imaxs[2] } floor(($z - 0.5) * $decimate + 0.5) .. ceil(($z + 0.5) * $decimate - 0.5);
396                         my $innerz_raw = $z * $decimate;
397                         my $innerz = floor($innerz_raw + 0.5);
398                         $innerz = $imins[2] if $innerz < $imins[2];
399                         $innerz = $imaxs[2] if $innerz > $imaxs[2];
400                         for my $y($newimins[1]..$newimaxs[1])
401                         {
402                                 my @oldy = grep { $_ >= $imins[1] && $_ <= $imaxs[1] } floor(($y - 0.5) * $decimate + 0.5) .. ceil(($y + 0.5) * $decimate - 0.5);
403                                 my $innery_raw = $y * $decimate;
404                                 my $innery = floor($innery_raw + 0.5);
405                                 $innery = $imins[1] if $innery < $imins[1];
406                                 $innery = $imaxs[1] if $innery > $imaxs[1];
407                                 for my $x($newimins[0]..$newimaxs[0])
408                                 {
409                                         my @oldx = grep { $_ >= $imins[0] && $_ <= $imaxs[0] } floor(($x - 0.5) * $decimate + 0.5) .. ceil(($x + 0.5) * $decimate - 0.5);
410                                         my $innerx_raw = $x * $decimate;
411                                         my $innerx = floor($innerx_raw + 0.5);
412                                         $innerx = $imins[0] if $innerx < $imins[0];
413                                         $innerx = $imaxs[0] if $innerx > $imaxs[0];
414
415                                         my @vec = (0, 0, 0);
416                                         my @dir = (0, 0, 0);
417                                         my @amb = (0, 0, 0);
418                                         my $weight = 0;
419                                         my $innercell = $gridcells[($innerx - $imins[0]) + $isize[0] * ($innery - $imins[1]) + $isize[0] * $isize[1] * ($innerz - $imins[2])];
420                                         for my $Z(@oldz)
421                                         {
422                                                 for my $Y(@oldy)
423                                                 {
424                                                         for my $X(@oldx)
425                                                         {
426                                                                 my $cell = $gridcells[($X - $imins[0]) + $isize[0] * ($Y - $imins[1]) + $isize[0] * $isize[1] * ($Z - $imins[2])];
427
428                                                                 my $cellweight = BoxIntersection(
429                                                                         $X, $Y, $Z, 1, 1, 1,
430                                                                         map { $_ * $decimate } $x, $y, $z, 1, 1, 1
431                                                                 );
432
433                                                                 $dir[$_] += $cellweight * $cell->{directional}->[$_] for 0..2;
434                                                                 $amb[$_] += $cellweight * $cell->{ambient}->[$_] for 0..2;
435                                                                 my @norm = DecodeDirection $cell->{dir};
436                                                                 $vec[$_] += $cellweight * $norm[$_] for 0..2;
437                                                                 $weight += $cellweight;
438                                                         }
439                                                 }
440                                         }
441                                         if($weight)
442                                         {
443                                                 $dir[$_] /= $weight for 0..2;
444                                                 $dir[$_] *= $filter for 0..2;
445                                                 $dir[$_] += (1 - $filter) * $innercell->{directional}->[$_] for 0..2;
446
447                                                 $amb[$_] /= $weight for 0..2;
448                                                 $amb[$_] *= $filter for 0..2;
449                                                 $amb[$_] += (1 - $filter) * $innercell->{ambient}->[$_] for 0..2;
450
451                                                 my @norm = DecodeDirection $innercell->{dir};
452                                                 $vec[$_] /= $weight for 0..2;
453                                                 $vec[$_] *= $filter for 0..2;
454                                                 $vec[$_] += (1 - $filter) * $norm[$_] for 0..2;
455
456                                                 $innercell = {
457                                                         ambient => \@amb,
458                                                         directional => \@dir,
459                                                         dir => EncodeDirection @norm
460                                                 };
461                                         }
462
463                                         push @newgridcells, $innercell;
464                                 }
465                         }
466                 }
467
468                 $bsp[$lumpid{lightgrid}]->[2] = EncodeLump \@newgridcells,
469                         qw/ambient=C3 directional=C3 dir=C2/;
470                 splice @entitylines, $gridsizeindex, 1, ()
471                         if defined $gridsizeindex;
472                 splice @entitylines, 1, 0, qq{"gridsize" "$newgridsize"};
473                 $bsp[$lumpid{entities}]->[2] = join "\n", @entitylines;
474         }
475         elsif(/^-x(.+)$/) # extract lump to stdout
476         {
477                 my $id = $lumpid{$1};
478                 die "invalid lump $1 to extract"
479                         unless defined $id;
480                 print $bsp[$id]->[2];
481         }
482         elsif(/^-o(.+)?$/) # write the final BSP file
483         {
484                 my $outfile = $1;
485                 $outfile = $fn
486                         if not defined $outfile;
487                 open my $fh, ">", $outfile
488                         or die "$outfile: $!";
489                 print $fh $header;
490                 my $pos = 17 * 8 + tell($fh) + length $msg;
491                 for(@bsp)
492                 {
493                         $_->[0] = $pos;
494                         $_->[1] = length $_->[2];
495                         $pos += $_->[1];
496                         print $fh pack "VV", $_->[0], $_->[1];
497                 }
498                 print $fh $msg;
499                 for(@bsp)
500                 {
501                         print $fh $_->[2];
502                 }
503                 close $fh;
504                 print STDERR "Wrote $outfile\n";
505         }
506         else
507         {
508                 die "Invalid option: $_";
509         }
510 }
511
512 # TODO:
513 #   features like:
514 #     decimate light grid
515 #     edit lightmaps/grid