#!/usr/bin/perl

# midi3.cgi:  A PERL script to generate a "multi-part"  MIDI files from 
# -----------                 a text description on an HTML Form

# Latest update: v3 (dec 2004)
# Written 2001 by Jean Vaucher,  http://www.iro.umontreal.ca/~vaucher/

#  WWW Directory of files: http://www-perso.iro.umontreal.ca/~vaucher/SCRIPTS/

#  Source    :     midi.pl  (alias that points to midi3.cgi)
#  Interface :     rhythm2.html   that calls "midi3.cgi"
#  DOCUMENTATION:  midi2.txt

# Dec 2004:  implemented Flams  f & F notes
# May 2002:  added "Lead" parameter to make one part stand out 
# May 2003:  added Content-Length HTTP param to allow Netscape 7.0 to work 

# OLDER Versions:
# 	midi2.pl : alias for midi2.cgi
# Derived from previous single part generator: "midi.cgi" & "rhythm.html"
#   July 2001, itself adapted from a script by Jeff Senn & interface by N. Gray
#   URL:  http://www-perso.iro.umontreal.ca/~vaucher/SCRIPTS/rhythm.html
#
#command line usage example:
#
#  % perl midi3.cgi part1=Bo.oB-C-B-o-B-C  debug=1 
#  % midi3.cgi part1=Bo.oB-C-B-o-B-C  > X.mid 
#   or test with @ARGV = ('part1=Bo.oB-C-B-o-B-C','repeat=2');
# ========================================================================



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,$mask) = @_; 
    $mask = 0 unless $mask;
    local($b) = $v & 0x7f | $mask ;
    $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( $clks * $npb );  # PPQN: pulses (clicks) per Quarter Note
}

sub writebpm {
    local($bpm) = $_[0];
    use integer;
#   local($tt) = ( $npb == 3 ? 40000000 : 60000000) /$bpm;
    local($tt) = 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)
          .( $npb == 3 ? chr(6).chr(3) : chr(4).chr(2) )
          .chr(24).chr(8);
}

# =================== Sound design functions grouped here ==========================

sub initVoices
{
    local($s)="";
        
    $s = chr(0).chr(0xc0).chr(117)  # Channel 1 = melodic Tom  Left
        .chr(0).chr(0xb0).chr(0x0A).chr(30) if $chan[0]; 

    $s .= chr(0).chr(0xc1).chr(116)        # chan 2 = Taiko
         .chr(0).chr(0xb1).chr(0x0A).chr(90) if $chan[1]; 
                
    $s .= chr(0).chr(0xc2).chr(32)          # chan 3 = Electric Bass
         .chr(0).chr(0xb2).chr(0x0A).chr(75) if $chan[2]; 
        
    $s .= chr(0).chr(0xc3).chr(37)          # chan 4 = Slap Bass
         .chr(0).chr(0xb3).chr(0x0A).chr(40) if $chan[3]; 
                    
    $s .= chr(0).chr(0xc4).chr(115)         # chan 5 = Woodblock
         .chr(0).chr(0xb4).chr(0x0A).chr(100)  if $chan[4]; 
       
    $s .= chr(0).chr(0xc5).chr(114)         # chan 6 = Steel drums
         .chr(0).chr(0xb5).chr(0x0A).chr(0) if $chan[5];        

    return $s;
    
#      .chr(0).chr(0xba).chr( 0).chr(0x7f)  # for XG, set channel 11 
#      .chr(0).chr(0xba).chr(32).chr(0x00)  # to Drums
#      .chr(0).chr(0xca).chr(0)  ;          # to Standard Drum Set
}

sub doNote
{   
  local($dt, $code, $note, $vol) = @_ ;
  
  if ( $note>99 )
  {
    $ch = int($note/100)-1; $nn1= $note%100;
    $chan[$ch] = 1;
    return &doEvent( $dt, 0x90+$ch, $nn1, $vol);
  }
  elsif ( $note>25 )
  {
    return &doEvent( $dt, 0x99, $note, $vol);
  }
  elsif ( $note == 1 )
  {
      return &doEvent( $dt, 0x99, 36, $vol) 
          .  &doEvent( 0, 0x99, 43, int(2*$vol/3)) 
          .  &doEvent( 0, 0x99, 54, int(0.4*$vol)) ;
  }  
  elsif ( $note == 2 )   # DunDun   B/C with CowBell
  {
      return &doEvent( $dt, 0x99, 41, int(0.8*$vol)) 
          .  &doEvent( 0, 0x99, 35, int(0.5*$vol)) 
          .  &doEvent( 0, 0x99, 56, int(0.6*$vol)) ;
  }
  elsif ( $note == 3 )   # DunDun   O with Bell
  {
      return &doEvent( $dt, 0x99, 43,  $vol) 
          .  &doEvent( 0, 0x99, 56, int(0.7*$vol)) ;
  }  
  
  elsif ( $note == 4 )   # Sangban   B/C with Bell
  {
      return &doEvent( $dt, 0x99, 36, $vol) 
           .  &doEvent( 0, 0x99, 68, int($vol/2)) ;
  }
  elsif ( $note == 5 )   # Sangban   O with Bell
  {
      return &doEvent( $dt, 0x99, 45, $vol) 
          .  &doEvent( 0, 0x99, 68, int($vol/2)) ;
  }
  
  elsif ( $note == 6 )   # Kenkeni   B/C with Bell
  {
      return &doEvent( $dt, 0x99, 64, int(0.8*$vol)) 
          .  &doEvent( 0, 0x99, 67, int($vol/2)) ;
  }
  elsif ( $note == 7 )   # Kenkeni   O with Bell
  {
      return &doEvent( $dt, 0x99, 47, $vol) 
          .  &doEvent( 0, 0x99, 66, int(0.3*$vol)) 
          .  &doEvent( 0, 0x99, 67, int($vol/2)) ;
  }
  elsif ( $note == 8 )   # Djembe1   C with Bell
  {
      return &doEvent( $dt, 0x99, 50, $vol) 
          .  &doEvent( 0, 0x99, 65, int(0.2*$vol)) 
          .  &doEvent( 0, 0x99, 54, int(0.4*$vol)) ;
  }
  else {
    return "";
  } 
}

$voice{"DunDun"}   = "B:3,C:2,O:3,X:56:70" ;
$voice{"Sangban"}  = "B:5,C:4,O:5,X:68:50" ;
$voice{"Kenkeni"}  = "B:7,C:6,O:7,X:67:50" ;

$voice{"Djembe1"} = "B:64,O:63,C:61,S:37";
$voice{"Djembe2"} = "B:1,O:64,C:8,S:60";
$voice{"Djembe3"} = "B:36,O:48,C:65:80,S:61";

$voice{"Bell"}   = "L:56,X:68:85,M:67,H:80,S:53,B:56,O:68:85,C:53" ;
$voice{"Conga"}  = "H:62,T:62:40,B:36:110,O:63,S:60,C:60";
$voice{"Shaker"} = "X:82,L:69,M:70,H:54,S:39,C:42" ;
# $voice{"Wood"} = "X:555,B:555,L:77,M:76,C:37,S:31" ;
$voice{"Wood"}   = "B:37,O:77,M:77,C:75,L:555,H:76,X:31" ;

#   $voice{"Metal"}  = "X:75,L:86,M:66,H:65,C:87,S:50" ;

$voice{"Tumba"} = "H:36,T:36:40,B:41,O:64,S:37,C:37";
$voice{"Quinto"} = "H:35,T:35:40,B:63,O:61,S:60,C:60";
#   $voice{"Bass"}   = "X:333:50,B:328:50,O:333:50,C:336:50" ;

# ================================================================================

# GLOBAL VARIABLES

$flam = "";
$clks = 6;     # clicks per note; with $npb (notes/beat) gives PPQN 
$npb  = 4;
$dt   = 0;
$pad  = $clks-2;  # interval between 2 notes

$song1 = "";
$gap = 0;      # time gap to next end piece.... must be put in front of next
               #     segment
$leadn = -1;    # part to emphasize

sub writerhythm 
{
    local($rep, $bpm) = @_ ;
    local($i, $dt);
    local($c,$tt);
    local($t) ='';

    $t =  $song1 ;
    $tt = &genMidi() ; 

    for($i = 0; $i < $rep ; $i++) {  
        $t .= $tt ; 
    }    
    $t .= &writevar($gap);
            
    $t = &writetempo(). &writebpm($bpm). &initVoices(). $t ;
    return &writeTrkheader( 1 ) . &writetrk($t);
}


sub genMidi  # INPUT from globals:   @notes, $n_notes & $gap
{
    local( $dt, $chord, $note, $vol, $t, $s, @ns);

#    if($debug) { print "    GenMIDI: $flam\n"  ; }
    $dt=$gap;
    foreach $chord (@notes) 
    {
    	  
    	  if( substr( $flam,0,1) eq "f" && $dt > 3) {
    	  		$t .=  &doNote( $dt-2, 0x99, 61, 100)
    	  		     . &doNote( 1, 0x99, 61, 0);
    	  		$dt = 1;
    	  	}
        $flam = substr( $flam,1);
    	  
        @ns = split(',',$chord);
        foreach $s (@ns) {
    	  	if($debug) { print " ** $s\n"  ; }
            ($note, $vol) = split(':',$s);
            $t .= &doNote( $dt, 0x99, $note,$vol);
            $dt = 0; 
        }
        $dt += 2;
        foreach $s (@ns) {
            ($note, $vol) = split(':',$s);
            $t .= &doNote( $dt, 0x99, $note, 0);
            $dt = 0; 
        }
        $dt += $clks-2;
    }
    $gap = $dt;
    if ( $gap > $pad) {
    	$t .= &doEvent( $gap-$pad, 0x99, 16, 1 ) . &doEvent( 0, 0x99, 16, 0); ;
   		$gap = $pad;  
    } 
   
    return $t;
}

sub genIntro
{
    local( $t, $i);

    for($i = 0; $i < $npb-1 ; $i++) 
    {  
        $t .= &doEvent( $gap, 0x99, 56, 60 )
            . &doEvent(    2, 0x99, 56,  0 );
        $gap = $npb*$clks - 2;
    }
    
    $t .= &doEvent( $gap, 0x99, 37, 40 )
        . &doEvent(    2, 0x99, 37,  0 );
    
    local($signal)   = $keywords{'signal'};
    $signal =~ s/[\s|]//g ;

	$n_notes = length($signal);   
	$flam = '-' x $n_notes;
 
    doPart( $signal, "Djembe1", 1.2);
    $t .= &genMidi();

	@notes   = () ;
    $n_notes = 0  ;
    $flam    = "" ;
    return $t;
}


# -------------------------------------------------------------
#    Generator algorithm version 2
# -------------------------------------------------------------

@parts=();
$n_notes = 0;

sub addPart
{
    local($drumname, $partname) = @_;   
    local($part, $drum);
    $part = $keywords{$partname};
    return unless $part;
    $part =~ s/[\s|]//g ;
    $drum = $keywords{$drumname}; 
    push(@parts,  $part);
    push(@voices, ($drum ? $drum: "Conga"));
    
    if ($drumname eq $lead) { $leadn = $#parts; }

}

sub evenParts
{
    local($i, $t, $k, $n);
    $n_notes = 0;
    foreach  $t (@parts) { 
        $n = length($t);
        if ($n_notes < $n) { $n_notes=$n;}
    }

   for ($i=0; $i< @parts ; $i++) {
       $t = $parts[$i];
       $k = $n = length( $t );
       while ( $k < $n_notes ) {
          $parts[$i] .= $t;
          $k += $n;
       } 
   }
   
   $flam = "-" x $n_notes;
}

sub printParts 
{
   local($t);
   foreach  $t (@parts) { 
      print "==> $t \n"; 
   }
   print "\n";
}


sub doParts 
{
   local( $i);
   local($minv) = ($lead ? 0.7 : 1.0);
      
   for ($i= 0; $i< @parts; $i++) 
   {
       $dv = ($i == $leadn ? 1.1 : $minv);
       &doPart( $parts[$i], $voices[$i], $dv);
   }
}

sub doPart  
{
   local($t, $inst, $dv) = @_;
   local($j, $c, $ns ) ;

   &initSounds( $voice{ $inst } );
   for ($j=0; $j< $n_notes; $j++) 
   {
      $ns = $notes[$j];
      $c = substr($t,$j,1);
      if ($c ne '-') 
      {
         $ns .= "," if $ns;
         if ($c eq "F" || $c eq "f") { 
         	substr($flam,$j,1) = "f"; 
         	$c =~ tr/fF/OC/; 
         }
         $ns .= addNote( $c, $dv );
      }
      $notes[$j] = $ns;
   }
}

sub addNote {
    local($x, $dv) = @_ ;      # note letter
    local($xx);
    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 ) ;
    }
    $v = $dv * $v;
    $v = ( $v > 127 ? 127 : $v);

    return  $k . ":" . $v ;
}

sub printNotes
{
   local($i, $n);
   $i=0;
   foreach $n (@notes) {
        print "$i: $n \n";
        $i++;
   }

}

sub mergeNotes      # Works on the "notes" array
{
   local($i, $n, $delta, $t);
   local($name, $v1, $v2);
   local(@ns);
   local(%vals);
   
   $i=0;
   foreach $delta (@notes) 
   {
        unless ($delta) {
            push(@ns,"");
            next;
        }

        %vals=();
        @hits = split(',', $delta);
        foreach $t (@hits) {
            ($name, $v1) = split(':',$t);
            $v2 = $vals{ $name };
            if ($v2) {
                $vals{"$name"} = $v2 + int( $v1 - $v1*$v2/128 );
#               $vals{"$name"} = $v2 + int( ($v1 - $v1*$v2/128)/2 );
            } else {
                $vals{"$name"} = $v1;
            }
        }
        $t = ""; $i=0;
        while (($name,$v1) = each(%vals)) {
            if ($t) 
                { $t .= ",$name:$v1"; }
            else
                { $t = "$name:$v1"; }
        }
        push(@ns, $t);
        $i++;
   }
   @notes = @ns;
}


$oldcode = 0 ;

sub doEvent 
{ 
    local($dt, $code, $note, $vol) = @_ ;
    
    if($debug) { 
    	if ($vol==0) { 
    		  print "---- dt: $dt   off: $note \n"; }
    	else {print "---- dt: $dt  ON : $note \@ $vol \n"; }    
    }
    if ($code != $oldcode) {
        $oldcode=$code; 
        return &writevar($dt) . chr($code) .chr($note) . chr($vol);
    } else {
        return &writevar($dt) . chr($note).chr($vol); 
    }
}

sub hexDump 
{
    local($s)=@_;
    local($offset, $len, $data, @array);
    $offset = 0;
    $len = length($s);

    while ($len-$offset >= 16) {
        $data = substr($s,$offset,16);
        @array = unpack('N4', $data);
        $data =~tr/\0-\37\177-\377/./;
        printf "%8.08x    %8.08x  %8.08x  %8.08x  %8.08x    %s\n",$offset, @array, $data;
        $offset += 16;
       }
    
    # Now finish up the end a byte at a time.
    $data = substr($s,$offset);
    $len = length($data);
    if ($len)
       {
        @array = unpack('C*', $data);
        $data =~y/\0-\37\177-\377/./;
           for (@array)
              {
               $_ = sprintf('%2.2x', $_);
              }
           push(@array, '  ') while $len++ < 16;
           $data =~ s/[^ -~]/./g;
           printf "%8.08x    ",$offset;
           printf "%s%s%s%s  %s%s%s%s  %s%s%s%s  %s%s%s%s    %s\n",@array, $data;
    }
 
}

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

%keys   =  () ;
%volm   =  () ;    # NOTE:  Volume parameters must be in [1..127]
$hivol  = 100 ;    #        BEWARE,  128 is same as 0 !!!
$lowvol =  80 ;

$keys{"B"} = 64;        # lo conga    - djembe Ti
$keys{"C"} = 61;        # Lo Bongo    - djembe Ta
$keys{"O"} = 63;        # Open tone


$keys{"."} = 35;        # kick2 -  ghost note
$volm{"."} = 45;

sub initSounds 
{
    local($sounds)=@_;
    local($i,$name,$value,$vol);
    $sounds =~ s/\s//g;
    local(@tones) = split(',',$sounds);
    for($i = 0; $i<=$#tones; $i++) 
    {   
        ($name, $value, $vol) = split(':',$tones[$i]);
        $vol = $hivol unless defined $vol;
        $keys{$name} = $value;
        $volm{$name} = $vol;
        if ($name =~ /[A-Z]/) {
            $name =~ tr/[A-Z]/[a-z]/ ;
            $keys{$name} = $value;
            $volm{ $name } = ($vol>40 ? $vol-20 : int($vol/2));
        }  
    }   
}


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

    if(defined $ENV{'REQUEST_METHOD'}) 
    {
        $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;

        $keywords{$name} = $value;
    }

# Implement a use counter

# if (open (COUNT, '+<midiCount'))
# {
#    my $counter = <COUNT>; 
#    $counter++; 
#    seek (COUNT, 0, 0) or print $!; 
#    print COUNT $counter . "\n";
#    close (COUNT); 
# }


if (open (COUNT, '>>ATrace'))
{
	$host = $ENV{'HTTP_REFERER'};
	$t = time();
   print COUNT "midi4: $t, $host \n";
   close (COUNT); 
}

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

$repeats  = $keywords{'repeat'};   # 1-50 (default=1)
$bpm      = $keywords{'bpm'};      # 40-240 (default=120)
$mime     = $keywords{'mime'};     #      (default="audio/mid")
$npb      = $keywords{'npb'};      # notes / beat (usu. 3 or 4)
$debug    = $keywords{'debug'};
$lead     = $keywords{'Lead'};

if(!defined($repeats)) { $repeats = 2; }
if(!defined($bpm))     { $bpm  = 90; }
if(!defined($mime))    { $mime = "audio/mid"; }
if(!defined($npb) || $npb !~ /^\d+$/)     { $npb  = 4; }

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

if($debug) 
{
    print "Content-type: text/plain\n\n";
    print "PARAMS:\n";
    while (($key,$value) = each %keywords) {
        print "$key=$value\n";
    }
    print "\nVALUES:\n";
    print "   repeats = $repeats\n";
    print "   bpm     = $bpm\n";
    print "   mime    = $mime\n";
    print "   noheader= $noheader\n";    
    print "   lead    = $lead\n\n";    
}

$voice{"Custom"}  = $keywords{'sounds'};

$song1 = &genIntro();

&addPart('drum1','part1') unless $keywords{'mute1'};
&addPart('drum2','part2') unless $keywords{'mute2'};
&addPart('drum3','part3') unless $keywords{'mute3'};
&addPart('drum4','part4') unless $keywords{'mute4'};
&addPart('drum5','part5') unless $keywords{'mute5'};
&addPart('drum6','part6') unless $keywords{'mute6'};

unless (@parts) {
   @parts=( "b", ".cb" );
   @voices=( "Conga", "DunDun");
}

if($debug) {
    
    &printParts();
    &evenParts();
    &printParts();
    &doParts();
    &mergeNotes();
    &printNotes();
    $song = &writerhythm($repeats,$bpm);
    &hexDump( $song );

    exit(0);
}

    &evenParts();
    &doParts();
    &mergeNotes();

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

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

    print  $song;

0;