home   sections   references   cd:s   about   links   heptagon 
 no margins   view as black text on white background 


(By the way, if you want to print this page out you may want to switch to wide margins and white text on black background).

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;
}


Email: jens@panix.com

All content copyright © Jens Johansson 2024. No unathorized duplication, copying, mirroring, archival, or redistribution/retransmission allowed! Any offensively categorical statements passed off as facts herein should only be construed as my very opinionated opinions.