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