Add source for the new Vore Tournament logo. Uses clip art from http://www.openclipar...
[voretournament/voretournament.git] / 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 }