#!/usr/bin/perl

# midi.cgi:  A PERL script to generate MIDI files from a text rhythm description
# --------

# Original script written by:  Jeff Senn (JAS) 
#  Home page:  http://www.maya.com/local/senn/drum.html
#    Script :  http://www.khafif.com/rhy/rhymidi.perl
#    Example:  http://www.khafif.com/rhy/rhygen.html
#
# Modified July 2001 by Jean Vaucher  (http://www.iro.umontreal.ca/~vaucher/)
#   - simplified Perl Code
#   - made it easier to tailor sounds for different instruments
#   - added 'sounds' parameter to define new mapping on the fly
#   - adapted to Djembe

# Modified July 2001 by Jeff Senn: 
#   - added back in some features I wanted
#   - added back Middle Eastern default sounds

#command line usage examples:
#
# perl rhymidi.cgi rhythm=D---T---k-k-T---D---k-k-T---t-k- repeat=4 bpm=120 noheader=1 > foo1.mid
#
# perl rhymidi.cgi rhythm=B----BB-OO-bB--C-BB-OO-b repeat=4 african=1 noheader=1 > foo1.mid
#

sub writelong { local($v) = $_[0];
    return chr(($v / 0x01000000) & 0xff). chr(($v / 0x010000) & 0xff).
           chr(($v / 0x0100) & 0xff). chr($v & 0xff);  }
sub writeshort {
    local($v) = $_[0];
    return chr(($v / 0x0100) & 0xff). chr($v & 0xff); }
sub writevar {
    local($v) = $_[0]; local($b) = $v & 0x7f | $_[1];
    $v >>=7; if($v > 0) { return &writevar($v,0x80).chr($b & 0xff); }
    return chr($b & 0xff);
}
sub writetrk {
    local($t) = $_[0]; return "MTrk" .
        &writelong(length($t)+3) . $t . chr(0xff) . chr(0x2f) . chr(0x00);
}
sub writeTrkheader {
    local($ntks) = $_[0]; 
    return "MThd" .
      &writelong(6)  .  #header length
      &writeshort(0) . #single-multi-channel
      &writeshort( $ntks) . #one track
      &writeshort( ($tsig==8 ? 4 : 2 ) ); #division of quarter / resolution 4=standard-MIDI
}

# GLOBAL VARIABLES

$dt = 0;
$nq = '';
$tsig = 4;
$nn   = 0;

sub strike {
    local($x) = $_[0];
    local($delay) = $_[1];
    local($k) = $keys{$x};
    if(!$k) {
        local($xx) = $x; $xx =~ tr/a-z/A-Z/;
        $k = $keys{$xx};
        if(!$k) { $k = 75; }        #Clave
    }

    local($v) = $volm{$x} ;
    if( !defined($v) ){
           $v = ( $x =~ /[A-Z]/  ? $hivol : $lowvol ) ;
    }
    $nq .= chr($k);
    return &writevar($delay) . chr(0x99).chr($k).chr($v);
}

sub writebpm {
    local($bpm) = $_[0];
    use integer;
    local($tt) = ( $tsig == 3 ? 40000000 : 60000000) /$bpm;
    return chr(0).chr(0xff).chr(0x51).chr(3)
                 .chr($tt>>16 )
                 .chr($tt>>8  & 0xFF)
                 .chr($tt & 0xFF);
}

sub writetempo
{
    return chr(0).chr(0xff).chr(0x58).chr(4)
          .( $tsig == 3 ? chr(6).chr(3) : chr(4).chr(2) )
#          .( defined($ternary) ? chr(6).chr(3) : chr(4).chr(2) )
          .chr(24).chr(8);
}

sub writerhythm {
    local($x) = $_[0];
    local($qty) = $_[1];
    local($bpm) = $_[2];
    local($i, $nn, $dt);
    local($c);
    local($t) ='';
    local($tt)='';

    $nn = $dt = 0;

    for($i = 0; $i < length($x); $i++)
    {
        $c = substr($x,$i,1);
        if   ($c eq ' ' || $c eq '-' || $c eq '_') { $dt++; $nn++; }
        elsif($c eq '|' ) {}
        elsif($c eq '3' ) { $tsig = 3;}
        elsif($c eq '8' ) { $tsig = 8;}
        elsif($c eq '<')  { $dt--; $nn--;}
        else {
            if($dt > 0) { $t .= &notesoff();}
            $t .= &strike($c,$dt) ;
            $dt = 1; $nn++;
        }
    }
    $t .= &notesoff();

    for($i = 0; $i < $qty ; $i++) {
        $tt .= $t ;
    }
   
    if ($nn%3 == 0) { $tsig = 3; }  

    $tt .= &writevar($dt*$qty);
        $tt = &writetempo().&writebpm($bpm).$tt;

    return &writeTrkheader( 1 ) . &writetrk($tt);
}

sub notesoff {
    local($tt) = '';
    local($i,$c);
    for($i = 0; $i < length($nq); $i++)
    {
        $c = substr($nq,$i,1);

        $tt .= &writevar($dt). $c .chr(0x00);
        $dt = 0;
    }
    $nq = '';
        return $tt;
}


# -------------------------------------------------------------

%african_keys = ();
$african_keys{"B"} = 64;        # lo conga     - djembe Ti
$african_keys{"C"} = 61;        # Lo Bongo  - djembe Ta
$african_keys{"O"} = 63;        # Open tone
$african_keys{"x"} = 56;        # Cowbell
$african_keys{"X"} = 45;        # Low Tom       - Dundun
$african_keys{"."} = 35;        # kick2 -  ghost note
$african_keys{"D"} = 64;        # lo conga
$african_keys{"S"} = 60;        # Conga slap
$african_keys{"K"} = 60;        # Conga slap

%keys = ();
$keys{"D"} = 64;
$keys{"d"} = 64;
$keys{"T"} = 62;
$keys{"t"} = 62;
$keys{"K"} = 62;
$keys{"k"} = 62;
$keys{"G"} = 37; #35;
$keys{"g"} = 37; #35;
$keys{"S"} = 39; #76; #45;
$keys{"s"} = 39; #76; #45;
$keys{"m"} = 35;
$keys{"p"} = 63;
$keys{"P"} = 63;
$keys{"C"} = 45;
$keys{"c"} = 45;
$keys{"F"} = 64;
$keys{"f"} = 64;

# NOTE:  Volume parameters must be in [1..127]
#        BEWARE,  128 is same as 0 !!!

$hivol  = 127;
$lowvol =  50;

%african_volm   = ();
$african_volm{"x"} = 90;
$african_volm{"X"} = 127;
$african_volm{"."} =  45;

%volm = ();
$volm{"S"} = 127;
$volm{"s"} = 110;
$volm{"G"} = 127;
$volm{"g"} = 110;
$volm{"."} = 1;


sub initSounds {
    local($i,$name,$value);
        local(@tones) = split(',',$sounds);
    for($i = 0; $i<=$#tones; $i++) {
        ($name, $value) = split(':',$tones[$i]);
        $keys{$name} = $value;
    }   
}


# ------------------------------------------------------------
# Start of Main program

    if(defined $ENV{'REQUEST_METHOD'}) {

        $pathinfo  = $ENV{'PATH_INFO'};
        $pathtrans = $ENV{'PATH_TRANSLATED'};
        $req       = $ENV{'REQUEST_METHOD'};
        $req =~ tr/a-z/A-Z/;

        if ($req eq "POST") {
            read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
        } else {
            $buffer = $ENV{'QUERY_STRING'};
        }

        @ARGV = split('&',$buffer);
    }
    else  { $noheader = 1 ; }

    for($i = 0; $i<=$#ARGV; $i++) {
        ($name, $value) = split('=',$ARGV[$i]);
        $value =~ tr/+/ /;
        $value =~ s/%(..)/pack("C", hex($1))/eg;

        @av = split('=',$ARGV[$i]);
        $keywords{$name} = $value;
    }


# --------------------------------------
# Parameters:

$rhythm   = $keywords{'rhythm'};   # 
$repeats  = $keywords{'repeat'};   # 1-50 (default=1)
$bpm      = $keywords{'bpm'};      # 40-240 (default=120)
$mime     = $keywords{'mime'};     #      (default="audio/mid")
$sounds   = $keywords{'sounds'};   # mapping letters to sounds
$african  = $keywords{'african'};  #
                                   # D:64,T:62  => D=Lo Conga, T=Mute slap

$download = $keywords{'download'};
$debug    = $keywords{'debug'};

if(!defined($rhythm))  { $rhythm  = "B--C-bB-TT-b"; }  # Yankadi
if(!defined($repeats)) { $repeats = 4; }
if(!defined($bpm))     { $bpm   = 120; }
if(!defined($mime))    { $mime = "audio/mid"; }
if( defined($african) && $african) { %keys = %africankeys; %volm = %african_volm;}
if( defined($sounds))  { &initSounds(); }

if($repeats<1)  { $repeats = 1; }
if($repeats>50) { $repeats = 50; }
if($bpm<40)     { $bpm =  40; }
if($bpm>300)    { $bpm = 300; }

if($debug) {
    print "Content-type: text/plain\n\n";

    print "PARAMS:\n";
    while (($key,$value) = each %keywords) {
        print "$key=$value\n";
    }
    print "VALUES:\n";
    print "   rhythm  = $rhythm\n";
    print "   repeats = $repeats\n";
    print "   bpm     = $bpm\n";
    print "   mime    = $mime\n";
    print "   noheader= $noheader\n";
    exit(0);
}

if( defined($download) && $download )  {
  unless ($noheader) { print "Content-type: text/html\n\n"; }
  print 'Windows users: Right click on the link below and use "save link as" or "save target as" to save this file. (Do not forget to change the file name to end in ".mid").  Use the BACK button on your browser to return to the rhythm generator.';
  print '<P><A href="http://www.khafif.com/rhy/rhymidi.cgi?';
  print "rhythm=$rhythm&repeat=$repeats&bpm=$bpm&mime=$mime&type=.mid";
  print '">';
  print "http://www.khafif.com/rhy/rhymidi.cgi?rhythm=$rhythm&repeat=$repeats&bpm=$bpm&mime=$mime&type=.mid";
  print '</A>';
  exit(0);
}

$song = &writerhythm($rhythm,$repeats,$bpm);
$slen = length($song) ;

unless ($noheader) { print "Content-Length: $slen\n"; }
unless ($noheader) { print "Content-type: $mime\n\n"; }

print  $song;

0;