misc/tools/midi2cfg-ng.pl

   1 #!/usr/bin/perl
   2
   3 # converter from Type 1 MIDI files to CFG files that control bots with the Tuba and other weapons for percussion (requires g_weaponarena all)
   4
   5 use strict;
   6 use warnings;
   7 use MIDI;
   8 use MIDI::Opus;
   9 use Storable;
  10
  11 # workaround for possible refire time problems
  12 use constant SYS_TICRATE => 0.033333;
  13 #use constant SYS_TICRATE => 0;
  14
  15 use constant MIDI_FIRST_NONCHANNEL => 17;
  16 use constant MIDI_DRUMS_CHANNEL => 10;
  17
  18 die "Usage: $0 filename.conf midifile1 transpose1 midifile2 transpose2 ..."
  19         unless @ARGV > 1 and @ARGV % 2;
  20
  21 my $timeoffset_preinit = 2;
  22 my $timeoffset_postinit = 2;
  23 my $timeoffset_predone = 2;
  24 my $timeoffset_postdone = 2;
  25 my $timeoffset_preintermission = 2;
  26 my $timeoffset_postintermission = 2;
  27
  28 my ($config, @midilist) = @ARGV;
  29
  30 sub unsort(@)
  31 {
  32         return map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, rand] } @_;
  33 }
  34
  35 sub override($$);
  36 sub override($$)
  37 {
  38         my ($dest, $src) = @_;
  39         if(ref $src eq 'HASH')
  40         {
  41                 $dest = {}
  42                         if not defined $dest;
  43                 for(keys %$src)
  44                 {
  45                         $dest->{$_} = override $dest->{$_}, $src->{$_};
  46                 }
  47         }
  48         elsif(ref $src eq 'ARRAY')
  49         {
  50                 $dest = []
  51                         if not defined $dest;
  52                 for(@$src)
  53                 {
  54                         push @$dest, override undef, $_;
  55                 }
  56         }
  57         elsif(ref $src)
  58         {
  59                 $dest = Storable::dclone $src;
  60         }
  61         else
  62         {
  63                 $dest = $src;
  64         }
  65         return $dest;
  66 }
  67
  68 my $precommands = "";
  69 my $commands = "";
  70 my $busybots;
  71 my @busybots_allocated;
  72 my %notechannelbots;
  73 my $transpose = 0;
  74 my $notetime = undef;
  75 my $lowestnotestart = undef;
  76 my $noalloc = 0;
  77 sub botconfig_read($)
  78 {
  79         my ($fn) = @_;
  80         my %bots = ();
  81         open my $fh, "<", $fn
  82                 or die "<$fn: $!";
  83
  84         my $currentbot = undef;
  85         my $appendref = undef;
  86         my $super = undef;
  87         while(<$fh>)
  88         {
  89                 chomp;
  90                 s/\s*#.*//;
  91                 next if /^$/;
  92                 if(s/^\t\t//)
  93                 {
  94                         my @cmd = split /\s+/, $_;
  95                         if($cmd[0] eq 'super')
  96                         {
  97                                 push @$appendref, @$super
  98                                         if $super;
  99                         }
 100                         elsif($cmd[0] eq 'percussion') # simple import
 101                         {
 102                                 push @$appendref, @{$currentbot->{percussion}->{$cmd[1]}};
 103                         }
 104                         else
 105                         {
 106                                 push @$appendref, \@cmd;
 107                         }
 108                 }
 109                 elsif(s/^\t//)
 110                 {
 111                         if(/^include (.*)/)
 112                         {
 113                                 my $base = $bots{$1};
 114                                 $currentbot = override $currentbot, $base;
 115                         }
 116                         elsif(/^count (\d+)/)
 117                         {
 118                                 $currentbot->{count} = $1;
 119                         }
 120                         elsif(/^transpose (\d+)/)
 121                         {
 122                                 $currentbot->{transpose} ||= 0;
 123                                 $currentbot->{transpose} += $1;
 124                         }
 125                         elsif(/^channels (.*)/)
 126                         {
 127                                 $currentbot->{channels} = { map { $_ => 1 } split /\s+/, $1 };
 128                         }
 129                         elsif(/^programs (.*)/)
 130                         {
 131                                 $currentbot->{programs} = { map { $_ => 1 } split /\s+/, $1 };
 132                         }
 133                         elsif(/^init$/)
 134                         {
 135                                 $super = $currentbot->{init};
 136                                 $currentbot->{init} = $appendref = [];
 137                         }
 138                         elsif(/^intermission$/)
 139                         {
 140                                 $super = $currentbot->{intermission};
 141                                 $currentbot->{intermission} = $appendref = [];
 142                         }
 143                         elsif(/^done$/)
 144                         {
 145                                 $super = $currentbot->{done};
 146                                 $currentbot->{done} = $appendref = [];
 147                         }
 148                         elsif(/^note on (-?\d+)/)
 149                         {
 150                                 $super = $currentbot->{notes_on}->{$1};
 151                                 $currentbot->{notes_on}->{$1} = $appendref = [];
 152                         }
 153                         elsif(/^note off (-?\d+)/)
 154                         {
 155                                 $super = $currentbot->{notes_off}->{$1};
 156                                 $currentbot->{notes_off}->{$1} = $appendref = [];
 157                         }
 158                         elsif(/^percussion (\d+)/)
 159                         {
 160                                 $super = $currentbot->{percussion}->{$1};
 161                                 $currentbot->{percussion}->{$1} = $appendref = [];
 162                         }
 163                         elsif(/^vocals$/)
 164                         {
 165                                 $super = $currentbot->{vocals};
 166                                 $currentbot->{vocals} = $appendref = [];
 167                         }
 168                         else
 169                         {
 170                                 print "unknown command: $_\n";
 171                         }
 172                 }
 173                 elsif(/^bot (.*)/)
 174                 {
 175                         $currentbot = ($bots{$1} ||= {count => 0});
 176                 }
 177                 elsif(/^raw (.*)/)
 178                 {
 179                         $precommands .= "$1\n";
 180                 }
 181                 elsif(/^timeoffset_preinit (.*)/)
 182                 {
 183                         $timeoffset_preinit = $1;
 184                 }
 185                 elsif(/^timeoffset_postinit (.*)/)
 186                 {
 187                         $timeoffset_postinit = $1;
 188                 }
 189                 elsif(/^timeoffset_predone (.*)/)
 190                 {
 191                         $timeoffset_predone = $1;
 192                 }
 193                 elsif(/^timeoffset_postdone (.*)/)
 194                 {
 195                         $timeoffset_postdone = $1;
 196                 }
 197                 elsif(/^timeoffset_preintermission (.*)/)
 198                 {
 199                         $timeoffset_preintermission = $1;
 200                 }
 201                 elsif(/^timeoffset_postintermission (.*)/)
 202                 {
 203                         $timeoffset_postintermission = $1;
 204                 }
 205                 else
 206                 {
 207                         print "unknown command: $_\n";
 208                 }
 209         }
 210
 211         for(values %bots)
 212         {
 213                 for(values %{$_->{notes_on}}, values %{$_->{percussion}})
 214                 {
 215                         my $t = $_->[0]->[0] eq 'time' ? $_->[0]->[1] : 0;
 216                         $lowestnotestart = $t if not defined $lowestnotestart or $t < $lowestnotestart;
 217                 }
 218         }
 219
 220         return \%bots;
 221 }
 222 my $busybots_orig = botconfig_read $config;
 223
 224
 225 # returns: ($mintime, $maxtime, $busytime)
 226 sub busybot_cmd_bot_cmdinfo(@)
 227 {
 228         my (@commands) = @_;
 229
 230         my $mintime = undef;
 231         my $maxtime = undef;
 232         my $busytime = undef;
 233
 234         for(@commands)
 235         {
 236                 if($_->[0] eq 'time')
 237                 {
 238                         $mintime = $_->[1]
 239                                 if not defined $mintime or $_->[1] < $mintime;
 240                         $maxtime = $_->[1] + SYS_TICRATE
 241                                 if not defined $maxtime or $_->[1] + SYS_TICRATE > $maxtime;
 242                 }
 243                 elsif($_->[0] eq 'busy')
 244                 {
 245                         $busytime = $_->[1] + SYS_TICRATE;
 246                 }
 247         }
 248
 249         return ($mintime, $maxtime, $busytime);
 250 }
 251
 252 sub busybot_cmd_bot_matchtime($$$@)
 253 {
 254         my ($bot, $targettime, $targetbusytime, @commands) = @_;
 255
 256         # I want to execute @commands so that I am free on $targettime and $targetbusytime
 257         # when do I execute it then?
 258
 259         my ($mintime, $maxtime, $busytime) = busybot_cmd_bot_cmdinfo @commands;
 260
 261         my $tstart_max = defined $maxtime ? $targettime - $maxtime : $targettime;
 262         my $tstart_busy = defined $busytime ? $targetbusytime - $busytime : $targettime;
 263
 264         return $tstart_max < $tstart_busy ? $tstart_max : $tstart_busy;
 265 }
 266
 267 # TODO function to find out whether, and when, to insert a command before another command to make it possible
 268 # (note-off before note-on)
 269
 270 sub busybot_cmd_bot_test($$$@)
 271 {
 272         my ($bot, $time, $force, @commands) = @_;
 273
 274         my $bottime = defined $bot->{timer} ? $bot->{timer} : -1;
 275         my $botbusytime = defined $bot->{busytimer} ? $bot->{busytimer} : -1;
 276
 277         my ($mintime, $maxtime, $busytime) = busybot_cmd_bot_cmdinfo @commands;
 278
 279         if($time < $botbusytime)
 280         {
 281                 warn "FORCE: $time < $botbusytime"
 282                         if $force;
 283                 return $force;
 284         }
 285
 286         if(defined $mintime and $time + $mintime < $bottime)
 287         {
 288                 warn "FORCE: $time + $mintime < $bottime"
 289                         if $force;
 290                 return $force;
 291         }
 292
 293         return 1;
 294 }
 295
 296 sub busybot_cmd_bot_execute($$@)
 297 {
 298         my ($bot, $time, @commands) = @_;
 299
 300         $bot->{lastuse} = $time;
 301
 302         for(@commands)
 303         {
 304                 if($_->[0] eq 'time')
 305                 {
 306                         $commands .= sprintf "sv_cmd bot_cmd %d wait_until %f\n", $bot->{id}, $time + $_->[1];
 307                         if($bot->{timer} > $time + $_->[1] + SYS_TICRATE)
 308                         {
 309                                 #use Carp; carp "Negative wait: $bot->{timer} <= @{[$time + $_->[1] + SYS_TICRATE]}";
 310                         }
 311                         $bot->{timer} = $time + $_->[1] + SYS_TICRATE;
 312                 }
 313                 elsif($_->[0] eq 'busy')
 314                 {
 315                         $bot->{busytimer} = $time + $_->[1] + SYS_TICRATE;
 316                 }
 317                 elsif($_->[0] eq 'buttons')
 318                 {
 319                         my %buttons_release = %{$bot->{buttons} ||= {}};
 320                         for(@{$_}[1..@$_-1])
 321                         {
 322                                 /(.*)\??/ or next;
 323                                 delete $buttons_release{$1};
 324                         }
 325                         for(keys %buttons_release)
 326                         {
 327                                 $commands .= sprintf "sv_cmd bot_cmd %d releasekey %s\n", $bot->{id}, $_;
 328                                 delete $bot->{buttons}->{$_};
 329                         }
 330                         for(@{$_}[1..@$_-1])
 331                         {
 332                                 /(.*)(\?)?/ or next;
 333                                 defined $2 and next;
 334                                 $commands .= sprintf "sv_cmd bot_cmd %d presskey %s\n", $bot->{id}, $_;
 335                                 $bot->{buttons}->{$_} = 1;
 336                         }
 337                 }
 338                 elsif($_->[0] eq 'cmd')
 339                 {
 340                         $commands .= sprintf "sv_cmd bot_cmd %d %s\n", $bot->{id}, join " ", @{$_}[1..@$_-1];
 341                 }
 342                 elsif($_->[0] eq 'barrier')
 343                 {
 344                         $commands .= sprintf "sv_cmd bot_cmd %d barrier\n", $bot->{id};
 345                         $bot->{lastuse} = $bot->{timer} = $bot->{busytimer} = 0;
 346                 }
 347                 elsif($_->[0] eq 'raw')
 348                 {
 349                         $commands .= sprintf "%s\n", join " ", @{$_}[1..@$_-1];
 350                 }
 351         }
 352
 353         return 1;
 354 }
 355
 356 my $intermissions = 0;
 357
 358 sub busybot_intermission_bot($)
 359 {
 360         my ($bot) = @_;
 361         busybot_cmd_bot_execute $bot, 0, ['cmd', 'wait', $timeoffset_preintermission];
 362         busybot_cmd_bot_execute $bot, 0, ['barrier'];
 363         if($bot->{intermission})
 364         {
 365                 busybot_cmd_bot_execute $bot, 0, @{$bot->{intermission}};
 366         }
 367         busybot_cmd_bot_execute $bot, 0, ['barrier'];
 368         $notetime = $timeoffset_postintermission - $lowestnotestart;
 369 }
 370
 371 #my $busy = 0;
 372 sub busybot_note_off_bot($$$$)
 373 {
 374         my ($bot, $time, $channel, $note) = @_;
 375         #print STDERR "note off $bot:$time:$channel:$note\n";
 376         my ($busychannel, $busynote, $cmds) = @{$bot->{busy}};
 377         return 1
 378                 if not defined $cmds; # note off cannot fail
 379         die "Wrong note-off?!?"
 380                 if $busychannel != $channel || $busynote ne $note;
 381         $bot->{busy} = undef;
 382
 383         my $t = $time + $notetime;
 384         my ($mintime, $maxtime, $busytime) = busybot_cmd_bot_cmdinfo @$cmds;
 385
 386         # perform note-off "as soon as we can"
 387         $t = $bot->{busytimer}
 388                 if $t < $bot->{busytimer};
 389         $t = $bot->{timer} - $mintime
 390                 if $t < $bot->{timer} - $mintime;
 391
 392         busybot_cmd_bot_execute $bot, $t, @$cmds;
 393         return 1;
 394 }
 395
 396 sub busybot_get_cmds_bot($$$)
 397 {
 398         my ($bot, $channel, $note) = @_;
 399         my ($k0, $k1, $cmds, $cmds_off) = (undef, undef, undef, undef);
 400         if($channel <= 0)
 401         {
 402                 # vocals
 403                 $cmds = $bot->{vocals};
 404                 if(defined $cmds)
 405                 {
 406                         $cmds = [ map { [ map { $_ eq '%s' ? $note : $_ } @$_ ] } @$cmds ];
 407                 }
 408                 $k0 = "vocals";
 409                 $k1 = $channel;
 410         }
 411         elsif($channel == 10)
 412         {
 413                 # percussion
 414                 $cmds = $bot->{percussion}->{$note};
 415                 $k0 = "percussion";
 416                 $k1 = $note;
 417         }
 418         else
 419         {
 420                 # music
 421                 $cmds = $bot->{notes_on}->{$note - ($bot->{transpose} || 0) - $transpose};
 422                 $cmds_off = $bot->{notes_off}->{$note - ($bot->{transpose} || 0) - $transpose};
 423                 $k0 = "note";
 424                 $k1 = $note - ($bot->{transpose} || 0) - $transpose;
 425         }
 426         return ($cmds, $cmds_off, $k0, $k1);
 427 }
 428
 429 sub busybot_note_on_bot($$$$$$$)
 430 {
 431         my ($bot, $time, $channel, $program, $note, $init, $force) = @_;
 432         return -1 # I won't play on this channel
 433                 if defined $bot->{channels} and not $bot->{channels}->{$channel};
 434         return -1 # I won't play this program
 435                 if defined $bot->{programs} and not $bot->{programs}->{$program};
 436
 437         my ($cmds, $cmds_off, $k0, $k1) = busybot_get_cmds_bot($bot, $channel, $note);
 438
 439         return -1 # I won't play this note
 440                 if not defined $cmds;
 441         return 0
 442                 if $bot->{busy};
 443         #print STDERR "note on $bot:$time:$channel:$note\n";
 444         if($init)
 445         {
 446                 return 0
 447                         if not busybot_cmd_bot_test $bot, $time + $notetime, $force, @$cmds;
 448                 busybot_cmd_bot_execute $bot, 0, ['cmd', 'wait', $timeoffset_preinit];
 449                 busybot_cmd_bot_execute $bot, 0, ['barrier'];
 450                 busybot_cmd_bot_execute $bot, 0, @{$bot->{init}}
 451                         if @{$bot->{init}};
 452                 busybot_cmd_bot_execute $bot, 0, ['barrier'];
 453                 for(1..$intermissions)
 454                 {
 455                         busybot_intermission_bot $bot;
 456                 }
 457                 # we always did a barrier, so we know this works
 458                 busybot_cmd_bot_execute $bot, $time + $notetime, @$cmds;
 459         }
 460         else
 461         {
 462                 return 0
 463                         if not busybot_cmd_bot_test $bot, $time + $notetime, $force, @$cmds;
 464                 busybot_cmd_bot_execute $bot, $time + $notetime, @$cmds;
 465         }
 466         if(defined $cmds and defined $cmds_off)
 467         {
 468                 $bot->{busy} = [$channel, $note, $cmds_off];
 469         }
 470         ++$bot->{seen}{$k0}{$k1};
 471         return 1;
 472 }
 473
 474 sub busybots_reset()
 475 {
 476         $busybots = Storable::dclone $busybots_orig;
 477         @busybots_allocated = ();
 478         %notechannelbots = ();
 479         $transpose = 0;
 480         $notetime = $timeoffset_postinit - $lowestnotestart;
 481 }
 482
 483 sub busybot_note_off($$$)
 484 {
 485         my ($time, $channel, $note) = @_;
 486
 487 #       print STDERR "note off $time:$channel:$note\n";
 488
 489         return 0
 490                 if $channel <= 0;
 491         return 0
 492                 if $channel == 10;
 493
 494         if(my $bot = $notechannelbots{$channel}{$note})
 495         {
 496                 busybot_note_off_bot $bot, $time, $channel, $note;
 497                 delete $notechannelbots{$channel}{$note};
 498                 return 1;
 499         }
 500
 501         return 0;
 502 }
 503
 504 sub busybot_note_on($$$$)
 505 {
 506         my ($time, $channel, $program, $note) = @_;
 507
 508         if($notechannelbots{$channel}{$note})
 509         {
 510                 busybot_note_off $time, $channel, $note;
 511         }
 512
 513 #       print STDERR "note on $time:$channel:$note\n";
 514
 515         my $overflow = 0;
 516
 517         my @epicfailbots = ();
 518
 519         for(map { $_->[1] } sort { $a->[1]->{lastuse} <=> $b->[1]->{lastuse} or $a->[0] <=> $b->[0] } map { [rand, $_] } @busybots_allocated)
 520         {
 521                 my $canplay = busybot_note_on_bot $_, $time, $channel, $program, $note, 0, 0;
 522                 if($canplay > 0)
 523                 {
 524                         $notechannelbots{$channel}{$note} = $_;
 525                         return 1;
 526                 }
 527                 push @epicfailbots, $_
 528                         if $canplay == 0;
 529                 # wrong
 530         }
 531
 532         my $needalloc = 0;
 533
 534         for(unsort keys %$busybots)
 535         {
 536                 next if $busybots->{$_}->{count} <= 0;
 537                 my $bot = Storable::dclone $busybots->{$_};
 538                 $bot->{id} = @busybots_allocated + 1;
 539                 $bot->{classname} = $_;
 540                 my $canplay = busybot_note_on_bot $bot, $time, $channel, $program, $note, 1, 0;
 541                 if($canplay > 0)
 542                 {
 543                         if($noalloc)
 544                         {
 545                                 $needalloc = 1;
 546                         }
 547                         else
 548                         {
 549                                 --$busybots->{$_}->{count};
 550                                 $notechannelbots{$channel}{$note} = $bot;
 551                                 push @busybots_allocated, $bot;
 552                                 return 1;
 553                         }
 554                 }
 555                 die "Fresh bot cannot play stuff"
 556                         if $canplay == 0;
 557         }
 558
 559         if(@epicfailbots)
 560         {
 561                 # we cannot add a new bot to play this
 562                 # we could try finding a bot that could play this, and force him to stop the note!
 563
 564                 my @candidates = (); # contains: [$bot, $score, $offtime]
 565
 566                 # put in all currently busy bots that COULD play this, if they did a note-off first
 567                 for my $bot(@epicfailbots)
 568                 {
 569                         next
 570                                 if $busybots->{$bot->{classname}}->{count} != 0;
 571                         next
 572                                 unless $bot->{busy};
 573                         my ($busy_chan, $busy_note, $busy_cmds_off) = @{$bot->{busy}};
 574                         next
 575                                 unless $busy_cmds_off;
 576                         my ($cmds, $cmds_off, $k0, $k1) = busybot_get_cmds_bot $bot, $channel, $note;
 577                         next
 578                                 unless $cmds;
 579                         my ($mintime, $maxtime, $busytime) = busybot_cmd_bot_cmdinfo @$cmds;
 580                         my ($mintime_off, $maxtime_off, $busytime_off) = busybot_cmd_bot_cmdinfo @$busy_cmds_off;
 581
 582                         my $noteofftime = busybot_cmd_bot_matchtime $bot, $time + $notetime + $mintime, $time + $notetime, @$busy_cmds_off;
 583                         next
 584                                 if $noteofftime < $bot->{busytimer};
 585                         next
 586                                 if $noteofftime + $mintime_off < $bot->{timer};
 587
 588                         my $score = 0;
 589                         # prefer turning off long notes
 590                         $score +=  100 * ($noteofftime - $bot->{timer});
 591                         # prefer turning off low notes
 592                         $score +=    1 * (-$note);
 593                         # prefer turning off notes that already play on another channel
 594                         $score += 1000 * (grep { $_ != $busy_chan && $notechannelbots{$_}{$busy_note} && $notechannelbots{$_}{$busy_note}{busy} } keys %notechannelbots);
 595
 596                         push @candidates, [$bot, $score, $noteofftime];
 597                 }
 598
 599                 # we found one?
 600
 601                 if(@candidates)
 602                 {
 603                         @candidates = sort { $a->[1] <=> $b->[1] } @candidates;
 604                         my ($bot, $score, $offtime) = @{(pop @candidates)};
 605                         my $oldchan = $bot->{busy}->[0];
 606                         my $oldnote = $bot->{busy}->[1];
 607                         busybot_note_off $offtime - $notetime, $oldchan, $oldnote;
 608                         my $canplay = busybot_note_on_bot $bot, $time, $channel, $program, $note, 0, 1;
 609                         die "Canplay but not?"
 610                                 if $canplay <= 0;
 611                         warn "Made $channel:$note play by stopping $oldchan:$oldnote";
 612                         $notechannelbots{$channel}{$note} = $bot;
 613                         return 1;
 614                 }
 615         }
 616
 617         die "noalloc\n"
 618                 if $needalloc;
 619
 620         if(@epicfailbots)
 621         {
 622                 warn "Not enough bots to play this (when playing $channel:$note)";
 623 #               for(@epicfailbots)
 624 #               {
 625 #                       my $b = $_->{busy};
 626 #                       warn "$_->{classname} -> @{[$b ? qq{$b->[0]:$b->[1]} : 'none']} @{[$_->{timer} - $notetime]} ($time)\n";
 627 #               }
 628         }
 629         else
 630         {
 631                 warn "Note $channel:$note cannot be played by any bot";
 632         }
 633
 634         return 0;
 635 }
 636
 637 sub Preallocate(@)
 638 {
 639         my (@preallocate) = @_;
 640         busybots_reset();
 641         for(@preallocate)
 642         {
 643                 die "Cannot preallocate any more $_ bots"
 644                         if $busybots->{$_}->{count} <= 0;
 645                 my $bot = Storable::dclone $busybots->{$_};
 646                 $bot->{id} = @busybots_allocated + 1;
 647                 $bot->{classname} = $_;
 648                 busybot_cmd_bot_execute $bot, 0, ['cmd', 'wait', $timeoffset_preinit];
 649                 busybot_cmd_bot_execute $bot, 0, ['barrier'];
 650                 busybot_cmd_bot_execute $bot, 0, @{$bot->{init}}
 651                         if @{$bot->{init}};
 652                 busybot_cmd_bot_execute $bot, 0, ['barrier'];
 653                 --$busybots->{$_}->{count};
 654                 push @busybots_allocated, $bot;
 655         }
 656 }
 657
 658 sub ConvertMIDI($$)
 659 {
 660         my ($filename, $trans) = @_;
 661         $transpose = $trans;
 662
 663         my $opus = MIDI::Opus->new({from_file => $filename});
 664         my $ticksperquarter = $opus->ticks();
 665         my $tracks = $opus->tracks_r();
 666         my @tempi = (); # list of start tick, time per tick pairs (calculated as seconds per quarter / ticks per quarter)
 667         my $tick;
 668
 669         $tick = 0;
 670         for($tracks->[0]->events())
 671         {
 672                 $tick += $_->[1];
 673                 if($_->[0] eq 'set_tempo')
 674                 {
 675                         push @tempi, [$tick, $_->[2] * 0.000001 / $ticksperquarter];
 676                 }
 677         }
 678         my $tick2sec = sub
 679         {
 680                 my ($tick) = @_;
 681                 my $sec = 0;
 682                 my $curtempo = [0, 0.5 / $ticksperquarter];
 683                 for(@tempi)
 684                 {
 685                         if($_->[0] < $tick)
 686                         {
 687                                 # this event is in the past
 688                                 # we add the full time since the last one then
 689                                 $sec += ($_->[0] - $curtempo->[0]) * $curtempo->[1];
 690                         }
 691                         else
 692                         {
 693                                 # if this event is in the future, we break
 694                                 last;
 695                         }
 696                         $curtempo = $_;
 697                 }
 698                 $sec += ($tick - $curtempo->[0]) * $curtempo->[1];
 699                 return $sec;
 700         };
 701
 702         # merge all to a single track
 703         my @allmidievents = ();
 704         my $sequence = 0;
 705         for my $track(0..@$tracks-1)
 706         {
 707                 $tick = 0;
 708                 for($tracks->[$track]->events())
 709                 {
 710                         my ($command, $delta, @data) = @$_;
 711                         $command = 'note_off' if $command eq 'note_on' and $data[2] == 0;
 712                         $tick += $delta;
 713                         push @allmidievents, [$command, $tick, $sequence++, $track, @data];
 714                 }
 715         }
 716
 717         if(open my $fh, "$filename.vocals")
 718         {
 719                 my $scale = 1;
 720                 my $shift = 0;
 721                 for(<$fh>)
 722                 {
 723                         chomp;
 724                         my ($tick, $file) = split /\s+/, $_;
 725                         if($tick eq 'scale')
 726                         {
 727                                 $scale = $file;
 728                         }
 729                         elsif($tick eq 'shift')
 730                         {
 731                                 $shift = $file;
 732                         }
 733                         else
 734                         {
 735                                 push @allmidievents, ['note_on', $tick * $scale + $shift, $sequence++, -1, -1, $file];
 736                                 push @allmidievents, ['note_off', $tick * $scale + $shift, $sequence++, -1, -1, $file];
 737                         }
 738                 }
 739         }
 740
 741         @allmidievents = sort { $a->[1] <=> $b->[1] or $a->[2] <=> $b->[2] } @allmidievents;
 742
 743         my %midinotes = ();
 744         my $notes_stuck = 0;
 745         my %notes_seen = ();
 746         my %programs = ();
 747         my $t = 0;
 748         for(@allmidievents)
 749         {
 750                 $t = $tick2sec->($_->[1]);
 751                 my $track = $_->[3];
 752                 if($_->[0] eq 'note_on')
 753                 {
 754                         my $chan = $_->[4] + 1;
 755                         ++$notes_seen{$chan}{($programs{$chan} || 1)}{$_->[5]};
 756                         if($midinotes{$chan}{$_->[5]})
 757                         {
 758                                 --$notes_stuck;
 759                                 busybot_note_off($t - SYS_TICRATE, $chan, $_->[5]);
 760                         }
 761                         busybot_note_on($t, $chan, $programs{$chan} || 1, $_->[5]);
 762                         ++$notes_stuck;
 763                         $midinotes{$chan}{$_->[5]} = 1;
 764                 }
 765                 elsif($_->[0] eq 'note_off')
 766                 {
 767                         my $chan = $_->[4] + 1;
 768                         if($midinotes{$chan}{$_->[5]})
 769                         {
 770                                 --$notes_stuck;
 771                                 busybot_note_off($t - SYS_TICRATE, $chan, $_->[5]);
 772                         }
 773                         $midinotes{$chan}{$_->[5]} = 0;
 774                 }
 775                 elsif($_->[0] eq 'patch_change')
 776                 {
 777                         my $chan = $_->[4] + 1;
 778                         my $program = $_->[5] + 1;
 779                         $programs{$chan} = $program;
 780                 }
 781         }
 782
 783         print STDERR "For file $filename:\n";
 784         print STDERR "  Stuck notes: $notes_stuck\n";
 785
 786         for my $testtranspose(-127..127)
 787         {
 788                 my $toohigh = 0;
 789                 my $toolow = 0;
 790                 my $good = 0;
 791                 for my $channel(sort keys %notes_seen)
 792                 {
 793                         next if $channel == 10 or $channel < 0;
 794                         for my $program(sort keys %{$notes_seen{$channel}})
 795                         {
 796                                 for my $note(sort keys %{$notes_seen{$channel}{$program}})
 797                                 {
 798                                         my $cnt = $notes_seen{$channel}{$program}{$note};
 799                                         my $votehigh = 0;
 800                                         my $votelow = 0;
 801                                         my $votegood = 0;
 802                                         for(@busybots_allocated)
 803                                         {
 804                                                 next # I won't play on this channel
 805                                                         if defined $_->{channels} and not $_->{channels}->{$channel};
 806                                                 next # I won't play this program
 807                                                         if defined $_->{programs} and not $_->{programs}->{$program};
 808                                                 my $transposed = $note - ($_->{transpose} || 0) - $testtranspose;
 809                                                 if(exists $_->{notes_on}{$transposed})
 810                                                 {
 811                                                         ++$votegood;
 812                                                 }
 813                                                 else
 814                                                 {
 815                                                         ++$votehigh if $transposed >= 0;
 816                                                         ++$votelow if $transposed < 0;
 817                                                 }
 818                                         }
 819                                         if($votegood)
 820                                         {
 821                                                 $good += $cnt;
 822                                         }
 823                                         elsif($votelow >= $votehigh)
 824                                         {
 825                                                 $toolow += $cnt;
 826                                         }
 827                                         else
 828                                         {
 829                                                 $toohigh += $cnt;
 830                                         }
 831                                 }
 832                         }
 833                 }
 834                 next if !$toohigh != !$toolow;
 835                 print STDERR "  Transpose $testtranspose: $toohigh too high, $toolow too low, $good good\n";
 836         }
 837
 838         for my $program(sort keys %{$notes_seen{10}})
 839         {
 840                 for my $note(sort keys %{$notes_seen{10}{$program}})
 841                 {
 842                         my $cnt = $notes_seen{10}{$program}{$note};
 843                         my $votegood = 0;
 844                         for(@busybots_allocated)
 845                         {
 846                                 next # I won't play on this channel
 847                                         if defined $_->{channels} and not $_->{channels}->{10};
 848                                 next # I won't play this program
 849                                         if defined $_->{programs} and not $_->{programs}->{$program};
 850                                 if(exists $_->{percussion}{$note})
 851                                 {
 852                                         ++$votegood;
 853                                 }
 854                         }
 855                         if(!$votegood)
 856                         {
 857                                 print STDERR "Failed percussion $note ($cnt times)\n";
 858                         }
 859                 }
 860         }
 861
 862         while(my ($k1, $v1) = each %midinotes)
 863         {
 864                 while(my ($k2, $v2) = each %$v1)
 865                 {
 866                         busybot_note_off($t, $k1, $k2);
 867                 }
 868         }
 869
 870         for(@busybots_allocated)
 871         {
 872                 busybot_intermission_bot $_;
 873         }
 874         ++$intermissions;
 875 }
 876
 877 sub Deallocate()
 878 {
 879         print STDERR "Bots allocated:\n";
 880         my %notehash;
 881         my %counthash;
 882         for(@busybots_allocated)
 883         {
 884                 print STDERR "$_->{id} is a $_->{classname}\n";
 885                 ++$counthash{$_->{classname}};
 886                 while(my ($type, $notehash) = each %{$_->{seen}})
 887                 {
 888                         while(my ($k, $v) = each %$notehash)
 889                         {
 890                                 $notehash{$_->{classname}}{$type}{$k} += $v;
 891                         }
 892                 }
 893         }
 894         for my $cn(sort keys %counthash)
 895         {
 896                 print STDERR "$counthash{$cn} bots of $cn have played:\n";
 897                 for my $type(sort keys %{$notehash{$cn}})
 898                 {
 899                         for my $note(sort { $a <=> $b } keys %{$notehash{$cn}{$type}})
 900                         {
 901                                 my $cnt = $notehash{$cn}{$type}{$note};
 902                                 print STDERR "  $type $note ($cnt times)\n";
 903                         }
 904                 }
 905         }
 906         for(@busybots_allocated)
 907         {
 908                 busybot_cmd_bot_execute $_, 0, ['cmd', 'wait', $timeoffset_predone];
 909                 busybot_cmd_bot_execute $_, 0, ['barrier'];
 910                 if($_->{done})
 911                 {
 912                         busybot_cmd_bot_execute $_, 0, @{$_->{done}};
 913                 }
 914                 busybot_cmd_bot_execute $_, 0, ['cmd', 'wait', $timeoffset_postdone];
 915                 busybot_cmd_bot_execute $_, 0, ['barrier'];
 916         }
 917 }
 918
 919 my @preallocate = ();
 920 $noalloc = 0;
 921 for(;;)
 922 {
 923         $commands = "";
 924         eval
 925         {
 926                 Preallocate(@preallocate);
 927                 my @l = @midilist;
 928                 while(@l)
 929                 {
 930                         my $filename = shift @l;
 931                         my $transpose = shift @l;
 932                         ConvertMIDI($filename, $transpose);
 933                 }
 934                 Deallocate();
 935                 my @preallocate_new = map { $_->{classname} } @busybots_allocated;
 936                 if(@preallocate_new == @preallocate)
 937                 {
 938                         print "$precommands$commands";
 939                         exit 0;
 940                 }
 941                 @preallocate = @preallocate_new;
 942                 $noalloc = 1;
 943                 1;
 944         } or do {
 945                 die "$@"
 946                         unless $@ eq "noalloc\n";
 947         };
 948 }