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