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