misc/tools/entmerge.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use Carp;
   6 $SIG{__DIE__} = sub {
   7         Carp::cluck "Exception: $@";
   8 };
   9
  10 # ent file managing tool
  11 # usage:
  12 #
  13 #   map -> ent:
  14 #     perl entmerge.pl $scalefactor             < mapname.map > mapname.ent
  15 #
  16 #   ent -> map:
  17 #     perl entmerge.pl $scalefactor mapname.ent < mapname.map > mapname-merged.map
  18 #
  19 #   bsp -> ent:
  20 #     perl bsptool.pl mapname.bsp -xentities                  > mapname.ent
  21 #
  22 #   ent -> bsp:
  23 #     perl bsptool.pl mapname.bsp -rentities                  < mapname.ent
  24
  25 sub DotProduct($$)
  26 {
  27         my ($a, $b) = @_;
  28         return  $a->[0]*$b->[0]
  29                 +       $a->[1]*$b->[1]
  30                 +       $a->[2]*$b->[2];
  31 }
  32
  33 sub CrossProduct($$)
  34 {
  35         my ($a, $b) = @_;
  36         return  [
  37                 $a->[1]*$b->[2] - $a->[2]*$b->[1],
  38                 $a->[2]*$b->[0] - $a->[0]*$b->[2],
  39                 $a->[0]*$b->[1] - $a->[1]*$b->[0]
  40         ];
  41 }
  42
  43 sub VectorMAM(@)
  44 {
  45         my (@data) = @_;
  46         my $out = [0, 0, 0];
  47         for my $coord(0..2)
  48         {
  49                 my $c = 0;
  50                 $c += $data[2*$_ + 0] * $data[2*$_ + 1]->[$coord]
  51                         for 0..(@data/2 - 1);
  52                 $out->[$coord] = $c;
  53         }
  54         return $out;
  55 }
  56
  57 sub VectorLength2($)
  58 {
  59         my ($v) = @_;
  60         return DotProduct $v, $v;
  61 }
  62
  63 sub VectorLength($)
  64 {
  65         my ($v) = @_;
  66         return sqrt VectorLength2 $v;
  67 }
  68
  69 sub VectorNormalize($)
  70 {
  71         my ($v) = @_;
  72         return VectorMAM 1/VectorLength($v), $v;
  73 }
  74
  75 sub Polygon_QuadForPlane($$)
  76 {
  77         my ($plane, $quadsize) = @_;
  78
  79         my $quadup;
  80         if(abs($plane->[2]) > abs($plane->[0]) && abs($plane->[2]) > abs($plane->[1]))
  81         {
  82                 $quadup = [1, 0, 0];
  83         }
  84         else
  85         {
  86                 $quadup = [0, 0, 1];
  87         }
  88
  89         $quadup = VectorMAM 1, $quadup, -DotProduct($quadup, $plane), $plane;
  90         $quadup = VectorMAM $plane->[3], VectorNormalize $quadup;
  91
  92         my $quadright = CrossProduct $quadup, $plane;
  93
  94         return [
  95                 VectorMAM($plane->[3], $plane, -$quadsize*2, $quadright, +$quadsize*2, $quadup),
  96                 VectorMAM($plane->[3], $plane, +$quadsize*2, $quadright, +$quadsize*2, $quadup),
  97                 VectorMAM($plane->[3], $plane, +$quadsize*2, $quadright, -$quadsize*2, $quadup),
  98                 VectorMAM($plane->[3], $plane, -$quadsize*2, $quadright, -$quadsize*2, $quadup)
  99         ];
 100 }
 101
 102 sub Polygon_Clip($$$)
 103 {
 104         my ($points, $plane, $epsilon) = @_;
 105
 106         if(@$points < 1)
 107         {
 108                 return [];
 109         }
 110
 111         my $n = 0;
 112         my $ndist = DotProduct($points->[$n], $plane) - $plane->[3];
 113
 114         my @outfrontpoints = ();
 115
 116         for my $i(0..@$points - 1)
 117         {
 118                 my $p = $n;
 119                 my $pdist = $ndist;
 120                 $n = ($i+1) % @$points;
 121                 $ndist = DotProduct($points->[$n], $plane) - $plane->[3];
 122                 if($pdist >= -$epsilon)
 123                 {
 124                         push @outfrontpoints, $points->[$p];
 125                 }
 126                 if(($pdist > $epsilon && $ndist < -$epsilon) || ($pdist < -$epsilon && $ndist > $epsilon))
 127                 {
 128                         my $frac = $pdist / ($pdist - $ndist);
 129                         push @outfrontpoints, VectorMAM 1-$frac, $points->[$p], $frac, $points->[$n];
 130                 }
 131         }
 132
 133         return \@outfrontpoints;
 134 }
 135
 136 sub MakePlane($$$)
 137 {
 138         my ($p, $q, $r) = @_;
 139
 140         my $a = VectorMAM 1, $q, -1, $p;
 141         my $b = VectorMAM 1, $r, -1, $p;
 142         my $n = VectorNormalize CrossProduct $a, $b;
 143
 144         return [ @$n, DotProduct $n, $p ];
 145 }
 146
 147 sub GetBrushWindings($)
 148 {
 149         my ($planes) = @_;
 150
 151         my @windings = ();
 152
 153         for my $i(0..(@$planes - 1))
 154         {
 155                 my $winding = Polygon_QuadForPlane $planes->[$i], 65536;
 156
 157                 for my $j(0..(@$planes - 1))
 158                 {
 159                         next
 160                                 if $i == $j;
 161                         $winding = Polygon_Clip $winding, $planes->[$j], 1/64.0;
 162                 }
 163
 164                 push @windings, $winding
 165                         unless @$winding == 0;
 166         }
 167
 168         return \@windings;
 169 }
 170
 171 sub GetBrushMinMax($)
 172 {
 173         my ($brush) = @_;
 174
 175         if($brush->[0] =~ /^\(/)
 176         {
 177                 # plain brush
 178                 my @planes = ();
 179                 for(@$brush)
 180                 {
 181                         /^\(\s+(\S+)\s+(\S+)\s+(\S+)\s+\)\s+\(\s+(\S+)\s+(\S+)\s+(\S+)\s+\)\s+\(\s+(\S+)\s+(\S+)\s+(\S+)\s+\)\s+/
 182                                 or die "Invalid line in plain brush: $_";
 183                         push @planes, MakePlane [ $1, $2, $3 ], [ $4, $5, $6 ], [ $7, $8, $9 ];
 184                         # for any three planes, find their intersection
 185                         # check if the intersection is inside all other planes
 186                 }
 187
 188                 my $windings = GetBrushWindings \@planes;
 189
 190                 my (@mins, @maxs);
 191
 192                 for(@$windings)
 193                 {
 194                         for my $v(@$_)
 195                         {
 196                                 if(@mins)
 197                                 {
 198                                         for(0..2)
 199                                         {
 200                                                 $mins[$_] = $v->[$_] if $mins[$_] > $v->[$_];
 201                                                 $maxs[$_] = $v->[$_] if $maxs[$_] < $v->[$_];
 202                                         }
 203                                 }
 204                                 else
 205                                 {
 206                                         @mins = @$v;
 207                                         @maxs = @$v;
 208                                 }
 209                         }
 210                 }
 211
 212                 return undef
 213                         unless @mins;
 214                 return \@mins, \@maxs;
 215         }
 216
 217         die "Cannot decode this brush yet! brush is @$brush";
 218 }
 219
 220 sub BrushOrigin($)
 221 {
 222         my ($brushes) = @_;
 223
 224         my @org = ();
 225
 226         for my $brush(@$brushes)
 227         {
 228                 my $isorigin = 0;
 229                 for(@$brush)
 230                 {
 231                         $isorigin = 1
 232                                 if /\bcommon\/origin\b/;
 233                 }
 234                 if($isorigin)
 235                 {
 236                         my ($mins, $maxs) = GetBrushMinMax $brush;
 237                         @org = map { 0.5 * ($mins->[$_] + $maxs->[$_]) } 0..2
 238                                 if defined $mins;
 239                 }
 240         }
 241
 242         return \@org
 243                 if @org;
 244         return undef;
 245 }
 246
 247 sub ParseEntity($)
 248 {
 249         my ($fh) = @_;
 250
 251         my %ent = ( );
 252         my @brushes = ( );
 253
 254         while(<$fh>)
 255         {
 256                 chomp; s/\r//g; s/\0//g; s/\/\/.*$//; s/^\s+//; s/\s+$//; next if /^$/;
 257
 258                 if(/^\{$/)
 259                 {
 260                         # entity starts
 261                         while(<$fh>)
 262                         {
 263                                 chomp; s/\r//g; s/\0//g; s/\/\/.*$//; s/^\s+//; s/\s+$//; next if /^$/;
 264
 265                                 if(/^"(.*?)" "(.*)"$/)
 266                                 {
 267                                         # key-value pair
 268                                         $ent{$1} = $2;
 269                                 }
 270                                 elsif(/^\{$/)
 271                                 {
 272                                         my $brush = [];
 273                                         push @brushes, $brush;
 274
 275                                         while(<$fh>)
 276                                         {
 277                                                 chomp; s/\r//g; s/\0//g; s/\/\/.*$//; s/^\s+//; s/\s+$//; next if /^$/;
 278
 279                                                 if(/^\{$/)
 280                                                 {
 281                                                         # patch?
 282                                                         push @$brush, $_;
 283
 284                                                         while(<$fh>)
 285                                                         {
 286                                                                 chomp; s/\r//g; s/\0//g; s/\/\/.*$//; s/^\s+//; s/\s+$//; next if /^$/;
 287
 288                                                                 if(/^\}$/)
 289                                                                 {
 290                                                                         push @$brush, $_;
 291
 292                                                                         last;
 293                                                                 }
 294                                                                 else
 295                                                                 {
 296                                                                         push @$brush, $_;
 297                                                                 }
 298                                                         }
 299                                                 }
 300                                                 elsif(/^\}$/)
 301                                                 {
 302                                                         # end of brush
 303                                                         last;
 304                                                 }
 305                                                 else
 306                                                 {
 307                                                         push @$brush, $_;
 308                                                 }
 309                                         }
 310                                 }
 311                                 elsif(/^\}$/)
 312                                 {
 313                                         return \%ent, \@brushes;
 314                                 }
 315                         }
 316                 }
 317                 else
 318                 {
 319                         die "Unexpected line in top level: >>$_<<";
 320                 }
 321         }
 322
 323         return undef;
 324 }
 325
 326 sub UnparseEntity($$)
 327 {
 328         my ($ent, $brushes) = @_;
 329         my %ent = %$ent;
 330
 331         my $s = "{\n";
 332
 333         for(sort keys %ent)
 334         {
 335                 $s .= "\"$_\" \"$ent{$_}\"\n";
 336         }
 337
 338         if(defined $brushes)
 339         {
 340                 for(@$brushes)
 341                 {
 342                         $s .= "{\n";
 343                         $s .= "$_\n" for @$_;
 344                         $s .= "}\n";
 345                 }
 346         }
 347
 348         $s .= "}\n";
 349         return $s;
 350 }
 351
 352 my ($scale, $in_ent) = @ARGV;
 353
 354 $scale = 1
 355         if not defined $scale;
 356
 357 my @submodels = ();
 358 my @entities = ();
 359 my @entities_skipped = ();
 360
 361 # THIS part is always a .map file
 362 my $first = 1;
 363 my $keeplights;
 364 for(;;)
 365 {
 366         my ($ent, $brushes) = ParseEntity \*STDIN;
 367
 368         defined $ent
 369                 or last;
 370
 371         if($first && $ent->{classname} eq 'worldspawn')
 372         {
 373                 $keeplights = $ent->{_keeplights};
 374                 delete $ent->{_keeplights};
 375                 @submodels = ($brushes);
 376         }
 377         else
 378         {
 379                 if($first)
 380                 {
 381                         push @entities, { classname => "worldspawn" };
 382                         @submodels = ([]);
 383                 }
 384
 385                 if($ent->{classname} eq 'worldspawn')
 386                 {
 387                         $ent->{classname} = "worldspawn_renamed";
 388                 }
 389
 390                 if(grep { $_ eq $ent->{classname} } qw/group_info func_group misc_model _decal _skybox/)
 391                 {
 392                         push @entities_skipped, [$ent, $brushes];
 393                         next;
 394                 }
 395
 396                 if(!$keeplights && $ent->{classname} =~ /^light/)
 397                 {
 398                         push @entities_skipped, [$ent, $brushes];
 399                         next;
 400                 }
 401
 402                 if(@$brushes)
 403                 {
 404                         my $i = @submodels;
 405                         push @submodels, $brushes;
 406                         $ent->{model} = sprintf "*%d", $i;
 407                 }
 408         }
 409
 410         push @entities, $ent;
 411
 412         $first = 0;
 413 }
 414
 415 if($first)
 416 {
 417         push @entities, { classname => "worldspawn" };
 418         @submodels = ([]);
 419 }
 420
 421 if(defined $in_ent)
 422 {
 423         # translate map using ent to map
 424         open my $fh, "<", $in_ent
 425                 or die "$in_ent: $!";
 426
 427         # THIS part is always an .ent file now
 428         my @entities_entfile = ();
 429         $first = 1;
 430
 431         my $clear_all_worldlights;
 432
 433         for(;;)
 434         {
 435                 my ($ent, $brushes) = ParseEntity $fh;
 436
 437                 defined $ent
 438                         or last;
 439
 440                 if($first && $ent->{classname} eq 'worldspawn')
 441                 {
 442                 }
 443                 else
 444                 {
 445                         if($first)
 446                         {
 447                                 push @entities_entfile, { classname => "worldspawn" };
 448                         }
 449
 450                         if($ent->{classname} eq 'worldspawn')
 451                         {
 452                                 $ent->{classname} = "worldspawn_renamed";
 453                         }
 454
 455                         if(!$keeplights && $ent->{classname} =~ /^light/)
 456                         {
 457                                 # light entity detected!
 458                                 # so let's replace all light entities
 459                                 $clear_all_worldlights = 1;
 460                         }
 461                 }
 462
 463                 if(defined $ent->{model} and $ent->{model} =~ /^\*(\d+)$/)
 464                 {
 465                         my $entfileorigin = [ split /\s+/, ($ent->{origin} || "0 0 0") ];
 466                         my $baseorigin = BrushOrigin $submodels[$1];
 467
 468                         if(defined $baseorigin)
 469                         {
 470                                 my $org = VectorMAM 1, $entfileorigin, -1, $baseorigin;
 471                                 $ent->{origin} = sprintf "%.6f %.6f %.6f", @$org;
 472                         }
 473                 }
 474
 475                 push @entities_entfile, $ent;
 476                 $first = 0;
 477         }
 478         close $fh;
 479
 480         if($keeplights && !$entities_entfile[0]->{keeplights})
 481         {
 482                 # PROBLEM:
 483                 # the .ent file was made without keeplights
 484                 # merging it with the .map would delete all lights
 485                 # so insert all light entities here!
 486                 @entities_skipped = (@entities_skipped,
 487                         map
 488                         {
 489                                 my $submodel = undef;
 490                                 if(defined $_->{model} and $_->{model} =~ /^\*(\d+)$/)
 491                                 {
 492                                         $submodel = $submodels[$1];
 493                                 }
 494                                 [ $_, $submodel ]
 495                         }
 496                         grep
 497                         {
 498                                 $_->{classname} =~ /^light/
 499                         }
 500                         @entities
 501                 );
 502         }
 503
 504         if($clear_all_worldlights)
 505         {
 506                 # PROBLEM:
 507                 # the .ent file was made with keeplights
 508                 # the .map did not indicate so!
 509                 # so we must delete all lights from the skipped entity list
 510                 @entities_skipped = grep { $_->[0]->{classname} !~ /^light/ } @entities_skipped;
 511         }
 512
 513         if($first)
 514         {
 515                 push @entities_entfile, { classname => "worldspawn" };
 516         }
 517
 518         $first = 1;
 519         for(@entities_entfile)
 520         {
 521                 my %e = %$_;
 522                 my $submodel = undef;
 523
 524                 $e{gridsize} = "64 64 128" if not exists $e{gridsize} and $first;
 525                 $e{lip} /= $scale if exists $e{lip};
 526                 $e{origin} = sprintf '%.6f %.6f %.6f', map { $_ / $scale } split /\s+/, $e{origin} if exists $e{origin};
 527                 $e{gridsize} = sprintf '%.6f %.6f %.6f', map { $_ / $scale } split /\s+/, $e{gridsize} if exists $e{gridsize} and $first;
 528
 529                 if($first)
 530                 {
 531                         $submodel = $submodels[0];
 532                         if($keeplights)
 533                         {
 534                                 $e{_keeplights} = 1;
 535                         }
 536                         else
 537                         {
 538                                 delete $e{_keeplights};
 539                         }
 540                 }
 541                 elsif(defined $e{model} and $e{model} =~ /^\*(\d+)$/)
 542                 {
 543                         $submodel = $submodels[$1];
 544                         delete $e{model};
 545                 }
 546                 print UnparseEntity \%e, $submodel;
 547                 $first = 0;
 548         }
 549         for(@entities_skipped)
 550         {
 551                 print UnparseEntity $_->[0], $_->[1];
 552                 $first = 0;
 553         }
 554 }
 555 else
 556 {
 557         # translate map to ent
 558         $first = 1;
 559         for(@entities)
 560         {
 561                 my %e = %$_;
 562
 563                 if($first)
 564                 {
 565                         if($keeplights)
 566                         {
 567                                 $e{_keeplights} = 1;
 568                         }
 569                         else
 570                         {
 571                                 delete $e{_keeplights};
 572                         }
 573                 }
 574
 575                 if(defined $e{model} and $e{model} =~ /^\*(\d+)$/)
 576                 {
 577                         my $oldorigin = [ split /\s+/, ($e{origin} || "0 0 0") ];
 578                         my $org = BrushOrigin $submodels[$1];
 579
 580                         if(defined $org)
 581                         {
 582                                 $org = VectorMAM 1, $org, 1, $oldorigin;
 583                                 $e{origin} = sprintf "%.6f %.6f %.6f", @$org;
 584                         }
 585                 }
 586
 587                 $e{gridsize} = "64 64 128" if not exists $e{gridsize} and $first;
 588                 $e{lip} *= $scale if exists $e{lip};
 589                 $e{origin} = sprintf '%.6f %.6f %.6f', map { $_ * $scale } split /\s+/, $e{origin} if exists $e{origin};
 590                 $e{gridsize} = sprintf '%.6f %.6f %.6f', map { $_ * $scale } split /\s+/, $e{gridsize} if exists $e{gridsize} and $first;
 591
 592                 print UnparseEntity \%e, undef;
 593                 $first = 0;
 594         }
 595 }