Listing of polymath.cgi

#!/usr/local/bin/perl5

#
# polymath.cgi
# (c) jens johansson 2001
# logic adapted from notes I made in 1986 on a piece of old notebook paper
# inspired into action 15 years later by steve vai's tempomental page 
# [ www.vai.com/LittleBlackDots/tempomental.html ]
#

$* = 1;
$version = "made by polymath.cgi v0.3, jens johansson. visit http://jens.org/ maybe.";

#
# there are some horrible spagetti brain-fart hacks here now to allow for multi-
# track macros. if anyone gets a brain hemmorhage trying to understand this code 
# I can but offer lame apologies.
# "All hail perl for unleashing power to reinvent the wheel, and making square wheels,
# into the hands of amateurs!" :)
#

&varinit;

$string =~ s/^#.*$//g;  # strip comments
$string =~ s/([\*\|\,])/ $1 /g; # add whitespace...
$string =~ s/([\%]{1,2})/ $1 /g; # add whitespace...
$string = " $string ";
$string = &expand_mul_fancier($string);
$string = &expand_mul_fancy($string);

$string = &expand_macros($string);
$string = &expand_mul_fancier($string);
$string = &expand_mul_fancy($string);
$string =~ s/(%{1,2})/|$1/g; # add new track before %% if not there
@track = split(/\|/, $string);
#
#   prepend (M, 1 1)
#   @partstring = ();
#   inner loop over each (split (M a b)) {
#      push(@partstring, expand...(a / b or something, vel, etc )
#   }
#   join(" ", @partstring)
#

&pre_out();
foreach (@track) {
   if (/^\s*$/){ next; } # ignore empty trk
   if (/%/) {
      if (/%%/) {$abspos_next = 0; }
      s/%//g;
      $notenum = 0; $abspos = $abspos_next; 
      &txtmsg("%: track/note continuation hack; set abspos to $abspos");
   }
   unless($abspos == 0) {
      $_ = "${abspos}A $_";
   }
   $_ = &pre_track($_);
   &get_note;
#  $_ = &expand_mul_fancy($_);
#print "\n$_";
   $_ = &expand_directives($_);
#print "\n$_";
   $_ = &expand_items(1, $_);
   &add_track($_, $chan-1, $note, $vel);
}

&post_out;

#
# that's all! well almost :)
#

sub expand_macros {
   my $string = $_[0]; my $count = 0;
   my $string2 = "";
   my $foundmacro = 0;
   my $success; my $begin; my $end; my $middle;
   
#   for each '() pair'
   while (
      ($success, $begin, $end, $middle) = &excise($string, '(', ')'),
      $success) {
      my ($func, @arg) = &excise_split($middle, ',', '(', ')');
      $func =~ s/\s+//g; $func =~ tr/a-z/A-Z/;
      if ($func eq "D") {
            $middle = "";                 # remove whatever was contained in () pair.
            my ($mac_key) = shift(@arg);
            $mac_key =~ s/\s+//g;
            $macro{$mac_key} = $arg[0];
            &txtmsg("macro defined; $mac_key <= $macro{$mac_key}");
            $foundmacro = 1;

      } elsif ($func eq "N") {
         $middle = "";
         $notes = shift(@arg);
         &txtmsg("set notes; $notes");
         &procnotes();
      } elsif ($func eq "T") {
         $middle = "";              
         $tempo = $arg[0];
         &txtmsg("set tempo; $tempo");
      } else {

#        none of our business just yet, just tack ()'s on again and pass it on
         $middle = "( $middle )";
      }
#
      $string2 .= $begin . $middle;
      $string = $end;
   }

   $string = $string2 . $string;

#
# done defining macros, now expand all macros
#

   my $exp_something = 1;

   while ($exp_something) {
      $exp_something = 0;
      if (500 < $count++) {&error("macro expansion ran amok. self-reference?"); }      
      if ($foundmacro) {
         txtmsg("expanding macros in this: '$string'");
         $exp_something += (
         $string =~
         s/\$([a-z0-9\-_]+)/(! defined($macro{$1}) ? &error("macro $1 not defined"):$macro{$1})/egi)
         ;
         $string =~ s/\s+/ /g;
         txtmsg("into this: '$string'");
      }
   }

#print "Content-type: text/plain\n\n$string";
#die ;

   $string;
}

sub expand_directives {
   my $string = $_[0]; my $something_was_expanded = 1; my $count = 0;
   my $string2 = "";
   my $success; my $begin; my $end; my $middle;
   
   while ($something_was_expanded) {
      $something_was_expanded = 0;
      $count++;
      if (500 < $count++) {&error("expansion ran amok"); }
#   for each '() pair'
      while (
         ($success, $begin, $end, $middle) = &excise($string, '(', ')'),
         $success) {
         my ($func, @arg) = &excise_split($middle, ',', '(', ')');
         $func =~ s/\s+//g; $func =~ tr/a-z/A-Z/;
         if ($func eq "V") {
             $middle = "";                
             &error("(V ...) not yet implemented");
#            set velocities
         } elsif ($func eq "C") {

#            set channels
             &error("(C ...) not yet implemented");
#           my ($chan) = shift(@arg);

         } elsif ($func eq "P") {
            my ($timing) = shift(@arg);
            $timing =~ s/\s//g;
            my ($pattern) = shift(@arg);
            $pattern =~ s/[\(\)]//g;
            $middle = "";              
            &txtmsg("expanding count-pattern, timing is $timing and pattern is $pattern");
            $pattern =~ s/([0-9]+)/"$timing " . (($timing . "P ") x ($1-1))/eg;
            &txtmsg("yield after number-substitution: $pattern");
            
            $pattern =~ s/([xo-])/($1 eq "x" || $1 eq "X" ? "$timing " : "${timing}P ")/egi;
            $pattern =~ s/([z])/"${timing}' "/egi;

            &txtmsg("yield after letter-substitution: $pattern");
            $middle = $pattern;           

         } else {
#
#           this ()-pair is still none of our business, so tack ()'s on
#           again and pass it on
#
            $middle = "( $middle )";
         }
#
      $string2 .= $begin . $middle;
      $string = $end;
      }

      $string = $string2 . $string;
   }
   $string =~ s/\s+/ /g;
   $string;
}

sub varinit {
   if ($ENV{'REQUEST_METHOD'} eq "GET") {
      $buffer = $ENV{'QUERY_STRING'};
   } else {
      read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
   }
   foreach (split(/&/, $buffer)) {
      ($name, $value) = split(/=/); $value =~ tr/+/ /;
      $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $F{$name} = $value;
   }

   $string = $F{'string'};
   $mediatype = $F{'mediatype'}; $tempo = $F{'tempo'}; $ppqn = $F{'ppqn'};
   $duty = $F{'duty'}; $notes = $F{'notes'}; $chan = $F{'chan'}; $vel = $F{'vel'};
   $dither = $F{'dither'}; 

   defined($mediatype) || ($mediatype = "audio/x-midi");
   defined($tempo) || ($tempo = 60);
   defined($ppqn) || ($ppqn = 192);
   defined($duty) || ($duty = 0.98);
   defined($notes) || ($notes = "T1 SD BD HH T2 CR OH CH T3");
   defined($chan) || ($chan = 10);
   defined($vel) || ($vel = 100);
   defined($dither) || ($dither = 0);

   $midi = ($mediatype !~ /text/i);       # generate midi data rather than text

# just for the initial demo page..
   if ($notes eq "T1 SD CR BD") {
      $notes = "T1 SD CR BD T2 HH OH CH";
   }
   
   &procnotes();
   
   %notemap = 
qw (BD 36 SD 38 HH 44 OH 46 CH 42 T1 48 T2 45 T3 43 CR 49 CS 52 CB 56);

   $abspos = 0;
   $abspos_next = 0;

}

sub get_note {
   $note = $notes[$notenum++];
   &txtmsg("setting note to $note");
   if ($notenum > @notes) {$notenum = 0; }
   if (defined($notemap{$note})) {
      $note = $notemap{$note}; 
      &txtmsg(", maps to $note");
   }
   &txtmsg("\n");
}

sub procnotes {
   $notes =~ s/^\s+//g; $notes =~ s/\s+$//g; $notes =~ s/\s+/ /g;
   $notes =~ tr/a-z/A-Z/;
   @notes = split(/\s/, $notes); $notenum = 0;  
}

sub txtmsg {
   unless ($midi) {
      $track .= "$_[0]\n";
   }
}

sub pre_out {
   if ((! $midi) && $track ne "") {
      push(@mtrack, "preprocess:\n$track\n");
   }
   $track = "";
}

sub pre_track {
   my $string2; my $string = $_[0];
   $track = ""; $string2 = $string;
   unless ($midi) {
      $string2 =~ s/^\s+//g;
      $string2 =~ s/\s+$//g;
      $track .= "starting new track. processed\n'$string2'\n\n";
   }
   $string =~ s/([*,()\[\]])/ $1 /g;
   $string =~ s/\s+/ /g;
   " $string ";
}

#
# generate the midi track (or text) from premangled
# string of simple tuplet numbers. take care to do
# all the internal timing as floats so we don't get
# accumulating rounding / truncation errors due to
# sequencer granularity
#
sub add_track {
   my ($string, $chan, $note, $vel) = @_;
   my ($sum, $length, $ticks_on, $ticks_off);
   my $seqtime = 0; my $abstime = 0; my ($delta_on, $delta_off);
   my @values = split(/\s+/, $string);
   $sum = 0;
   unless ($midi) {
      $track .= "abspos is $abspos.\ntiming (tuplet) values are:\n";
      foreach (@values) {
         if (/^$/) {next; }
         if ($_ =~ /([\d.]+)A$/i) { # absolute pos, make pause
            $sum += $1;
            $track .= $1 . "[bar-abs-pos] ";
         } else {
            $sum += 1 / $_;
            $track .= "$_ ";
         }
      }  
      $track .= "\n\ntiming values in ticks are:\n";
      foreach (@values) {
         if (/^$/) {next; }
         if ($_ =~ /([\d.]+)A$/i) { # absolute pos (bars), make pause
            $track .= sprintf("%2.2f ", $ppqn * 4 * $_);
         } else {
            $track .= sprintf("%2.2f ", $ppqn * 4 / $_);
         }
      }  
      $track .= "\n\ntotal track length is: $sum\n";
      push(@mtrack, $track);
      if ($abspos_next < $sum) {
         $abspos_next = $sum;
      }
   } else {
      $chan &= 0xF;     
      foreach (@values) {
         if (/^\s*$/) {next; }

         $pause = ($_ =~ s/([\d.]+)P$/$1/i);

         if ($_ =~ s/([\d.]+)A$/$1/i) { # absolute pos (bars), make pause
            $pause = 1;
            $length = $_;
         } else {
            if ($_ == 0) {next; }
            $length = 1 / $_;
         }

         $sum += $length;
         $length *= $ppqn * 4;

         if ($pause) {
            $abstime += $length;
         } else {
            $delta_on = &round($abstime) - $seqtime;
            $seqtime += $delta_on;
            $ticks_on = $duty * $length;
            $ticks_off = (1-$duty) * $length;
            $abstime += $ticks_on;
            $delta_off = &round($abstime) - $seqtime;
            $track .= pack ('w C3 w C3',
               $delta_on, 0x90 | $chan, $note, $vel,
               $delta_off, 0x80 | $chan, $note, 0);
            $seqtime += $delta_off;
            $abstime += $ticks_off;
         }
      }
      $track .= pack('w C3', &round($abstime) - $seqtime, 0xFF, 0x2f, 0); 
      push(@mtrack, $track); 
      if ($abspos_next < $sum) {$abspos_next = $sum; }
   }
}

sub round {
   int($_[0] + 0.5 + ($dither != 0 ? rand($dither)-$dither : 0) );
}

#
# wrap up SMF format details and emit result
#
sub post_out {
   my $pretrack; my $pretrack_output = 0;
   my $mtrack0; my $wholetrack = "";
   if ($midi) {
      my $t = 1000000 * 60 / $tempo;
      my $ntrks = @mtrack;
      $pretrack = "MThd" . pack('Nn3', 6, 1, $ntrks, $ppqn);
      $mtrack0 = pack('C3 C', 0, 0xFF, 1, length($version)) . $version .
         pack('C7', 0, 0xFF, 0x51, 3, ($t>>16)&0xFF, ($t>>8)&0xFF, $t&0xFF);

      foreach(@mtrack) {
         if (! $pretrack_output) {
            $mtrack0 .= $_;
            $wholetrack = $pretrack . "MTrk" . pack('N', length($mtrack0)) . $mtrack0;
            $pretrack_output = 1;
         } else {
            $wholetrack .= "MTrk" . pack('N', length($_)) . $_;
         }
      }
      binmode (STDOUT);    # I <heart> Bill Gates
   } else {
      $wholetrack = "resolution is $ppqn ticks per quarter note\n\n" .
         join("\n", @mtrack);
   }
   if ($outmode) {
      open O, ">out.mid"; binmode O;
      print O $wholetrack; close O;
   } else {
      print "Content-type: $mediatype\n\n$wholetrack";
   }
}

#
# find occurences of '*' and repeat previous simple item.
# 
#
sub expand_mul_fancy {
   my $string = $_[0];
   my ($pre, $what, $rpt, $post, $starpos);

   while (($starpos = index($string, "*")) != -1) {
      $pre = substr($string, 0, $starpos);
      $post = substr($string, $starpos+1, length($string)-$starpos);

      unless ($post =~ /([\d\.\*]+) (.*)\s*$/) {&error("illegal repeat"); }
      $rpt = $1; $post = $2;     
      if ($pre =~ /(.*) ([-\d'.\$a-z_|]+)\s*$/i) {
         $pre = $1; $what = $2;
         &txtmsg("(emf) repeating \n'$what'\n $rpt times, ");
         $what = (" $what " x $rpt);
         &txtmsg("result is\n'$what'\n");
         $string = $pre . $what . $post;
      }
   }
   $string;
}

#
# find occurences of '*' and recurse to repeat previous item.
#
sub expand_mul_fancier {
   my $string = $_[0]; 
   my $string2 = "";
   my $success; my $begin; my $end; my $middle;

#   for each '() pair'
   while (
      ($success, $begin, $end, $middle) = &excise($string, '(', ')'),
      $success) {
      
      $middle = &expand_mul_fancier($middle);

      if ($end =~ s/^\s*\*\s*([^\s]+)//i) {
         my $rpt = $1;
         unless ($rpt=~/[\d\.\*]+/) {&error("illegal repeat $rpt");}
         &txtmsg("(emff) repeating \n'( $middle ) '\n $rpt times, ");

         my ($func, @arg) = &excise_split($middle, ',', '(', ')');

#        if ($middle =~ /([|%])/) {
#           $middle = " $middle " x $rpt;
#           &txtmsg("repeat; found character $1, omitting parentheses, result is\n'$middle'\n");
#
#        } els

if ($#arg == -1) {

            $middle = " $middle " x $rpt;
            &txtmsg("repeat; found non-directive parentheses, omitting them, result is\n'$middle'\n");

         } else {
            $middle = " ( $middle ) " x $rpt;
            &txtmsg("repeat; result is\n'$middle'\n");
         }
      } else {
#
#        this ()-pair is none of our business, so tack ()'s on
#        again and pass it on
#
         $middle = "( $middle )";
      }
      $string2 .= $begin . $middle;
      $string = $end;
   }

   $string = $string2 . $string;
   $string =~ s/\s+/ /g;
   $string;
}

#
# low budget parser...
# keep lopping off first / outermost pair of parentheses, and multiply in
# factor derived from arguments into all "simple" items within those
# parentheses, recursively. yields a parenthesis-free string of
# (possibly non-integer) tuplet numbers.
#
sub expand_items {
   my ($factor, $string) = @_;
   my ($pause);

# kludge to allow (P ) inside a tuplet [ (5, 4, (P, 4, xxoxx)) ]
   $string = &expand_directives($string);

   my ($success, $begin, $end, $middle) = &excise($string, '(', ')');
   if ($success) {
#
# found () pair this recursion instance
#
      my (@arg) = &excise_split($middle, ',', '(', ')');
      my ($t, $n);
      if ($#arg == 1) {
         $t = $arg[0];
         $n = &guess_denominator($t);
         $middle = $arg[1];
      } elsif ($#arg == 2) {
         $t = $arg[0];
         $n = $arg[1];
         $middle = $arg[2];
      } else {
#         &error("( ... ) not 2 or 3 parts");
#
#        kludge to make () without commas legal..
#        a bit inefficient & inaccurate but..
#
         $t = $n = 1;
      }
      $begin = &expand_items($factor, $begin);
      $middle = &expand_items($factor * $t / $n, $middle);
      $end = &expand_items($factor, $end);
      $string = $begin . $middle . $end;
   } else {
#
# no () pair this recursion instance
#
      my (@values) = split(/\s+/, $string);
      foreach (@values) {
         if (/^$/) {next; }
#
# deal with abs
#
         if (/([\d.]+)A/i) {next; }

#
# deal with pause
#
         $pause = ($_ =~ s/([\d.]+)P$/$1/i);

#
# deal with dotted notes (some other day)
# !? N.   => 1/N + 1/2N                =  3/2N
#    N..  => 1/N + 1/2N + 1/4N         =  7/4N
#    N... => 1/N + 1/2N + 1/4N  + 1/8N = 15/8N
#
#        s/([\d]+)(\.+)$/$1*(2/3)**length($2)/eg;                 # wrong.
#        s/([\d]+)(\.+)$/$1*(2**length($2)/2**length($2)-1)/eg;   # also wrong.
#        s/([\d]+)(\.+)$/$1/g;                                    # also wrong :)

#finally??
         s#([\d]+)(\.+)$#     $1 / ( 1.5 ** length($2) )   #eg;

         
         $_ *= $factor;
         if ($pause) {$_ .= "P"; }
      }
      $string = join(" ", @values);
   }
   $string;
}

sub guess_denominator {
   my $v = int(log($_[0])/log(2));
   (2**($v+1)-$_[0] <=> $_[0]-2**$v) == -1 && $v++;
   2**$v;
}

sub error {
   my $string = $_[0];
   print "Content-type: text/plain\n\npolymath error: $string\n";
   unless ($midi) {
      print "these were the messages up until when the error occured: 
$track\n";
   }
   exit(1);
}

#
# return status and $string split in 3, while tracking nested open/closedelims
#
sub excise() {
   my($search_in, $opendelim, $closedelim) = @_;
   my($i, $rlen, $llen, $opendelim_count);
   $lmatch = index($search_in, $opendelim);
   if ($lmatch == -1) { return (0, '', '', ''); }
   $rlen = length($closedelim); $llen = length($opendelim);
   $opendelim_count = 1;
   for ($i=$lmatch+$llen; $i<=length($search_in)-$rlen && ($opendelim_count); ) {
      if (substr($search_in, $i, $llen) eq $opendelim) 
         {$opendelim_count++; $i+=$llen; next; }
      if (substr($search_in, $i, $rlen) eq $closedelim) 
         {$opendelim_count--; $rmatch = $i; $i+=$rlen; next; }
      $i++;
   }
   if ($opendelim_count) {
      &error("matching ".$opendelim."/".$closedelim." error"); 
   }
   ( 1, 
     substr($search_in, 0, $lmatch),
     substr($search_in, $rmatch + $rlen, length($search_in)-1),
     substr($search_in, $lmatch + $llen, $rmatch-$lmatch-$llen)
   )
}

#
# return $string split at split_char, while tracking nested open/closedelims
#
sub excise_split() {
   my($search_in, $split_char, $opendelim, $closedelim) = @_;
   my(@result, $len, $opendelim_count, $curchar, $j);
   my($i) = 0;
   $result[$i] = $search_in;
reloop:
   $len = length($result[$i]);
   for($j = 0; $j < $len; $j++) {
      $curchar = substr($result[$i], $j, 1);
      if ($curchar eq $split_char && !$opendelim_count) {
         $result[$i+1] = substr($result[$i], $j+1);
         $result[$i] = substr($result[$i], 0, $j);
         $i++;
         goto reloop;
      }
      if (index($opendelim, $curchar) != -1) {$opendelim_count++; }
      if (index($closedelim, $curchar) != -1) {$opendelim_count--;}
   }
   @result;
}